From 686bf7e8a8f1cfcc38f240f48c3423b5eb908a88 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 2 Aug 2019 18:17:09 +0000 Subject: [PATCH 01/38] feature/regional_grid This commit references #66330. Baseline Jim P's code to create regional grids. Add build for Theia. Change-Id: Ia2152105485a4e6362d37b98ad70ddbeb1d34f55 --- sorc/build_fre-nctools.sh | 9 + .../tools/regional_grid.fd/Makefile | 22 + .../tools/regional_grid.fd/build.sh | 38 + .../tools/regional_grid.fd/gen_schmidt.f90 | 477 ++++ .../tools/regional_grid.fd/hgrid_ak.f90 | 101 + .../tools/regional_grid.fd/pietc.f90 | 95 + .../tools/regional_grid.fd/pkind.f90 | 8 + .../tools/regional_grid.fd/pmat.f90 | 1082 +++++++++ .../tools/regional_grid.fd/pmat4.f90 | 1924 +++++++++++++++++ .../tools/regional_grid.fd/pmat5.f90 | 791 +++++++ .../tools/regional_grid.fd/psym2.f90 | 498 +++++ .../tools/regional_grid.fd/regional_grid.f90 | 125 ++ .../tools/regional_grid.fd/regional_grid.nml | 100 + 13 files changed, 5270 insertions(+) create mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/Makefile create mode 100755 sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh create mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/gen_schmidt.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/pietc.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/pkind.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/pmat.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/pmat4.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/pmat5.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/psym2.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/regional_grid.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/regional_grid.nml diff --git a/sorc/build_fre-nctools.sh b/sorc/build_fre-nctools.sh index 718adad42..c07414029 100755 --- a/sorc/build_fre-nctools.sh +++ b/sorc/build_fre-nctools.sh @@ -115,4 +115,13 @@ set -x cd $srcDir/tools/shave.fd ./build_shave $system_site +set +x +echo "///////////////////////////////////////////////////////////////////////////" +echo "///////////////////////////////////////////////////////////regional_grid //" +echo "///////////////////////////////////////////////////////////////////////////" +set -x + +cd $srcDir/tools/regional_grid.fd +./build.sh $system_site + exit diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/Makefile b/sorc/fre-nctools.fd/tools/regional_grid.fd/Makefile new file mode 100644 index 000000000..799e11b30 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/Makefile @@ -0,0 +1,22 @@ +SHELL := bash + +REGIONAL_GRID=regional_grid + +.PHONY: all +all : $(REGIONAL_GRID) + +$(REGIONAL_GRID): pkind.o pietc.o pmat.o pmat4.o pmat5.o psym2.o gen_schmidt.o hgrid_ak.o regional_grid.o + $(FCMP) $(FFLAGS) ${LIBS} -o $@ $^ + +.SUFFIXES: +.SUFFIXES: .f90 .o + +.f90.o: + $(FCMP) $(FFLAGS) -c $< + +.PHONY: clean +clean: + rm -f *.o *.mod $(REGIONAL_GRID) + +install: + cp $(REGIONAL_GRID) ../../../../exec diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh b/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh new file mode 100755 index 000000000..698d4e186 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh @@ -0,0 +1,38 @@ +#!/bin/sh + +set -x + +case $1 in + "cray" ) + export FCMP=ftn + export FFLAGS="-O2 -g" + export LIBS=blah ;; + "wcoss" ) + export FCMP=ifort + export FFLAGS="-O2 -g ${NETCDF_FFLAGS} ${NETCDF_LDFLAGS_F}" ;; + "wcoss_dell_p3" ) + export FCMP=ifort + export FFLAGS="-O2 -g ${NETCDF_FFLAGS} ${NETCDF_LDFLAGS_F}" ;; + "jet" ) + export FCMP=ifort + export FFLAGS="-O2 -g -I$NETCDF/include" + export LIBS="-L$NETCDF/lib -lnetcdff -lnetcdf -L${HDF5}/lib -lhdf5 -lhdf5_fortran" ;; + "theia" ) + export FCMP=ifort + export FFLAGS="-O2 -g -I$NETCDF/include" + export LIBS="-L$NETCDF/lib -lnetcdff -lnetcdf -L${HDF5}/lib -lhdf5 -lhdf5_fortran" ;; + *) + echo "REGIONAL GRID UTILITY BUILD NOT TESTED ON MACHINE $1" + exit 1 ;; +esac + +make clean +make +make install + +if ((rc != 0)); then + echo "ERROR BUILDING REGIONAL GRID UTILITY" + exit $rc +else + exit 0 +fi diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/gen_schmidt.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/gen_schmidt.f90 new file mode 100644 index 000000000..68fd2b6e2 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/gen_schmidt.f90 @@ -0,0 +1,477 @@ +!============================================================================= +subroutine get_qqt(nxh,nyh,ncor,j0xy,p,q) +!============================================================================= +! Assume the grid to be mirror-symmetric across both medians, so that the +! computation of the quality diagnostic, Q, need only involve the positive +! quadrant of the grid. The norm associated with the definition of Q is the +! Frobenius norm (Q is the grid-mean of the squared-Frobenius norm of the +! log of the Gram matrix of the given distribution of jacobian matrices.) +!============================================================================= +use pkind, only: dp +use pietc, only: u0,u1,o2 +use pmat4, only: outer_product +use psym2 +implicit none +integer, intent(in ):: nxh,nyh,ncor +real(dp),dimension(3,2,0:nxh,0:nyh),intent(in ):: j0xy +real(dp),dimension(2,2), intent(inout):: p +real(dp), intent( out):: q +!----------------------------------------------------------------------------- +integer,parameter :: nit=5 +real(dp),parameter :: acrit=1.e-8,dpx=.0099 +real(dp),dimension(0:nxh,0:nyh) :: wxy +real(dp),dimension(3,2) :: j0,j +real(dp),dimension(2,2) :: el,pf,elp,elmean,g,ppx,pmx,ppy,pmy +real(dp),dimension(2) :: hess,grad +real(dp) :: anorm,q00,qpx,qmx,qpy,qmy,c,w +integer :: ix,iy,lx,ly,it +!============================================================================= +call get_wxy(nxh,nyh,ncor,wxy)! <- get 2D extended trapezoidal averaging wts +if(p(1,1)==u0)then; p=0; p(1,1)=u1; p(2,2)=u1; endif +! Iteratively calibrate preconditioner, p, to make elmean vanish: +anorm=1 +do it=1,nit + elmean=0 + q=0 + do iy=0,nyh; do ix=0,nxh + j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) +! Precondition the Jacobian using latest iteration of P: + j=matmul(j0,p) +! Find the Gram matrix, G, implied by the column vectors of the new J: + g=matmul(transpose(j),j) +! Find the matrix logarithm, L = log(G), contrinutions to elmean and q: + call logsym2(g,el); el=el/2; elmean=elmean+w*el; q=q+w*sum(el**2) + enddo ; enddo + if(anormnit)then + print'("WARNING: In get_qqt, apparent failure of iteration to converge")' + read(*,*) +endif + +q00=q +ppx=p; ppx(1,1)=ppx(1,1)*(1+dpx);qpx=0 +pmx=p; pmx(1,1)=pmx(1,1)*(1-dpx);qmx=0 +ppy=p; ppy(2,2)=ppy(2,2)*(1+dpx);qpy=0 +pmy=p; pmy(2,2)=pmy(2,2)*(1-dpx);qmy=0 +do iy=0,nyh; do ix=0,nxh + j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) + j=matmul(j0,ppx); g=matmul(transpose(j),j) + call logsym2(g,el); el=el/2; qpx=qpx+w*sum(el**2) + j=matmul(j0,pmx); g=matmul(transpose(j),j) + call logsym2(g,el); el=el/2; qmx=qmx+w*sum(el**2) + j=matmul(j0,ppy); g=matmul(transpose(j),j) + call logsym2(g,el); el=el/2; qpy=qpy+w*sum(el**2) + j=matmul(j0,pmy); g=matmul(transpose(j),j) + call logsym2(g,el); el=el/2; qmy=qmy+w*sum(el**2) +enddo; enddo +! Estimate a (diagonal) Hessian matrix and a gradient vector: +hess=(/ (qpx-2*q00+qmx)/dpx**2, (qpy-2*q00+qmy)/dpx**2 /) +grad=(/ (qpx-qmx)/(2*dpx) , (qpy-qmy)/(2*dpx) /) + +!!print'('' hessian components:'',t30,2(1x,e20.14))',hess !!!!!!! +!!print'('' grad components:'',t30,2(1x,e20.14))',grad !!!!!!! +! If the hessian is positive, polish the final p with a final Newton iteration: +if(hess(1)>0 .and. hess(2)>0.)then + c=u1-grad(1)/hess(1); p(:,1)=p(:,1)*c + c=u1-grad(2)/hess(2); p(:,2)=p(:,2)*c +endif + +! and calculate the new q. Keep it only if is numerically smaller than before: +q00=0 +do iy=0,nyh; do ix=0,nxh + j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) + j=matmul(j0,p); g=matmul(transpose(j),j) + call logsym2(g,el); el=el/2; q00=q00+w*sum(el**2) +enddo; enddo +!!print'('' adjusted final q: '',e20.14)',q00 +if(q00nit)then + print'("WARNING: In get_qqt, apparent failure of iteration to converge")' + read(*,*) +endif + +q00=q +ppx=p; ppx(1,1)=ppx(1,1)*(1+dpx);qpx=0 +pmx=p; pmx(1,1)=pmx(1,1)*(1-dpx);qmx=0 +ppy=p; ppy(2,2)=ppy(2,2)*(1+dpx);qpy=0 +pmy=p; pmy(2,2)=pmy(2,2)*(1-dpx);qmy=0 +do iy=0,nyh; do ix=0,nxh + j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) + j=matmul(j0,ppx); g=matmul(transpose(j),j) + call logsym2(g,el);el=el/2;qpx=qpx+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) + j=matmul(j0,pmx); g=matmul(transpose(j),j) + call logsym2(g,el);el=el/2;qmx=qmx+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) + j=matmul(j0,ppy); g=matmul(transpose(j),j) + call logsym2(g,el);el=el/2;qpy=qpy+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) + j=matmul(j0,pmy); g=matmul(transpose(j),j) + call logsym2(g,el);el=el/2;qmy=qmy+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) +enddo; enddo +! Estimate a (diagonal) Hessian matrix and a gradient vector: +hess=(/ (qpx-2*q00+qmx)/dpx**2, (qpy-2*q00+qmy)/dpx**2 /) +hess=(/8.,8./) +grad=(/ (qpx-qmx)/(2*dpx) , (qpy-qmy)/(2*dpx) /) +! If the hessian is positive, polish p with a final Newton iteration: +if(hess(1)>0 .and. hess(2)>0.)then + c=u1-grad(1)/hess(1); p(:,1)=p(:,1)*c + c=u1-grad(2)/hess(2); p(:,2)=p(:,2)*c +endif + +! and calculate the new q. Keep it only if it's numerically smaller than before: +q00=0 +do iy=0,nyh; do ix=0,nxh + j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) + j=matmul(j0,p); g=matmul(transpose(j),j) + call logsym2(g,el);el=el/2;q00=q00+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) +enddo; enddo +if(q004)stop 'In get_wxy; ncor is out of bounds' +if(ncor>=min(nxh,nyh))stop 'In get_wxy; ncor is too large for this small grid' +! the wx and wy are the weight coefficients for an unnormalized +! extended trapezoidal integration. The end correction coefficients can +! be found by staggering, then summing, the Adams-Moulton coefficients +! at both ends. +wx=u1; wx(0)=o2; wx(nxh:nxh-ncor:-1)=cor +wy=u1; wy(0)=o2; wy(nyh:nyh-ncor:-1)=cor +wxy=outer_product(wx,wy); wxy=wxy/sum(wxy) +end subroutine get_wxy + +!============================================================================= +subroutine getedges(arcx,arcy,edgex,edgey) +!============================================================================= +! For angles (degrees) of the arcs spanning the halfwidths between the +! region's center and its x and y edges, get the two cartesian vectors +! that represent the locations of these edge midpoints in the positive x and y +! directions. +!============================================================================= +use pkind, only: dp +use pietc, only: u0,dtor +implicit none +real(dp), intent(in ):: arcx,arcy +real(dp),dimension(3),intent(out):: edgex,edgey +!------------------------------------------------------------------------------ +real(dp):: cx,sx,cy,sy +!============================================================================== +cx=cos(arcx*dtor); sx=sin(arcx*dtor) +cy=cos(arcy*dtor); sy=sin(arcy*dtor) +edgex=(/sx,u0,cx/); edgey=(/u0,sy,cy/) +end subroutine getedges + +!============================================================================== +subroutine xmtoxc_ak(a,kappa,xm,xc,xcd,ff) +!============================================================================== +! Assuming the A-kappa parameterization of the generalized schmidt-transformed +! gnomonic mapping, and given a map-space 2-vector, xm, find the corresponding +! cartesian unit 3-vector and its derivative wrt xm, jacobian matrix, xcd. +! If for any reason the mapping cannot be done, return a raised failure +! flag, FF. +!============================================================================= +use pkind, only: dp +use pietc, only: T,F +implicit none +real(dp), intent(in ):: a,kappa +real(dp),dimension(2), intent(in ):: xm +real(dp),dimension(3), intent(out):: xc +real(dp),dimension(3,2),intent(out):: xcd +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp),dimension(2,2):: xtd,xsd +real(dp),dimension(2) :: xt,xs +!============================================================================= +call xmtoxt(a,xm,xt,xtd,ff); if(ff)return +call xttoxs(kappa,xt,xs,xsd,ff); if(ff)return +xsd=matmul(xsd,xtd) +call xstoxc(xs,xc,xcd) +xcd=matmul(xcd,xsd) +end subroutine xmtoxc_ak + +!============================================================================= +subroutine xctoxm_ak(a,kappa,xc,xm,ff) +!============================================================================= +! Inverse mapping of xmtoxc_ak. That is, go from given cartesian unit 3-vector, +! xc, to map coordinate 2-vector xm (or return a raised failure flag, FF, if +! the attempt fails). +!============================================================================= +use pkind, only: dp +use pietc, only: F,T,u0,u1 +implicit none +real(dp), intent(in ):: a,kappa +real(dp),dimension(3),intent(in ):: xc +real(dp),dimension(2),intent(out):: xm +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp),dimension(2):: xs,xt +!============================================================================= +ff=F +call xctoxs(xc,xs) +call xstoxt(kappa,xs,xt,ff); if(ff)return +call xttoxm(a,xt,xm,ff) +end subroutine xctoxm_ak + +!============================================================================== +subroutine zmtozt(a,zm,zt,ztd,ff) +!============================================================================== +! Evaluate the function, zt = tan(sqrt(A)*z)/sqrt(A), and its deivative, ztd, +! for positive and negative A and for the limiting case, A --> 0 +!============================================================================== +use pkind, only: dp +use pietc, only: F,T,u1,pih +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>0)then; ra=sqrt( a); zt=tan (ra*zm)/ra; ff=abs(ra*zm)>=pih +elseif(a<0)then; ra=sqrt(-a); zt=tanh(ra*zm)/ra +else ; zt=zm +endif +ztd=u1+a*zt*zt +end subroutine zmtozt + +!============================================================================= +subroutine zttozm(a,zt,zm,ff) +!============================================================================= +! Inverse of zmtozt +!============================================================================= +use pkind, only: dp +use pietc, only: F,u1 +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>0)then; ra=sqrt( a); razt=ra*zt; zm=atan (razt)/ra +elseif(a<0)then; ra=sqrt(-a); razt=ra*zt; ff=abs(razt)>=u1; if(ff)return + zm=atanh(razt)/ra +else ; zm=zt +endif +end subroutine zttozm + +!============================================================================== +subroutine xmtoxt(a,xm,xt,xtd,ff) +!============================================================================== +! Like zmtozt, but for 2-vector xm and xt, and 2*2 diagonal Jacobian xtd +!============================================================================== +use pkind, only: dp +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:: i +!============================================================================== +xtd=0; do i=1,2; call zmtozt(a,xm(i),xt(i),xtd(i,i),ff); if(ff)return; enddo +end subroutine xmtoxt + +!============================================================================= +subroutine xttoxm(a,xt,xm,ff) +!============================================================================= +! Inverse of xmtoxt +!============================================================================ +use pkind, only: dp +use pietc, only: F +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:: i +!============================================================================= +do i=1,2; call zttozm(a,xt(i),xm(i),ff); if(ff)return; enddo +end subroutine xttoxm + +!============================================================================== +subroutine xttoxs(kappa,xt,xs,xsd,ff) +!============================================================================== +! Scaled gnomonic plane xt to standard stereographic plane xs +!============================================================================== +use pkind, only: dp +use pietc, only: u0,u1 +implicit none +real(dp), intent(in ):: kappa +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):: s,sp,rsp,rspp,rspps,rspdx,rspdy +!============================================================================== +s=kappa*(xt(1)*xt(1) + xt(2)*xt(2)); sp=u1+s +ff=(sp<=u0); if(ff)return +rsp=sqrt(sp) +rspp=u1+rsp +rspps=rspp**2 +xs=xt/rspp +rspdx=kappa*xt(1)/rsp +rspdy=kappa*xt(2)/rsp +xsd(1,1)=u1/rspp -xt(1)*rspdx/rspps +xsd(1,2)= -xt(1)*rspdy/rspps +xsd(2,1)= -xt(2)*rspdx/rspps +xsd(2,2)=u1/rspp -xt(2)*rspdy/rspps +end subroutine xttoxs + +!============================================================================= +subroutine xstoxt(kappa,xs,xt,ff) +!============================================================================= +! Inverse of xttoxs. +!============================================================================= +use pkind, only: dp +use pietc, only: u1 +implicit none +real(dp), intent(in ):: kappa +real(dp),dimension(2),intent(in ):: xs +real(dp),dimension(2),intent(out):: xt +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp):: s,sc +!============================================================================= +s=kappa*(xs(1)*xs(1)+xs(2)*xs(2)); sc=u1-s +ff=(sc<=0); if(ff)return +xt=2*xs/sc +end subroutine xstoxt + +!============================================================================= +subroutine xstoxc(xs,xc,xcd) +!============================================================================= +! 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 +!============================================================================= +use pkind, only: dp +use pietc, only: u1,u2 +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 xctoxs(xc,xs) +!============================================================================= +! Inverse of xstoxc. I.e., cartesians to stereographic +!============================================================================= +use pkind, only: dp +use pietc, only: u1 +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 diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 new file mode 100644 index 000000000..5f9f66473 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 @@ -0,0 +1,101 @@ +!============================================================================= +subroutine hgrid_ak(lx,ly,nx,ny,a,k,plat,plon,pazi, & + re,delx,dely, glat,glon,garea, ff) +!============================================================================= +! Use a and k as the parameters of a generalized Schmidt-transformed +! gnomonic mapping centered at (plat,plon) and twisted about this center +! by an azimuth angle of pazi counterclockwise (these angles in radians). +! +! Assuming the radius of the earth is re, and using the central mapping +! point as the coordinate origin, set up the grid with central x-spacing delx +! and y-spacing dely in physical units, 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, 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 +! in the SQUARE of the same physical length unit that was employed to define +! the radius of the earth, re (and the central grid steps, delx and dely). +! +! 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 pkind, only: dp +use pietc, only: u0,u1,dtor +use pmat4, only: sarea +use pmat5, only: ctog +implicit none +integer, intent(in ):: lx,ly,nx,ny +real(dp), intent(in ):: a,k,plat,plon,pazi, & + re,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, rre +integer :: 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/re + do ix=lx,mx + xm(1)=ix*delx/re + call xmtoxc_ak(a,k,xm,xc,xcd,ff) + if(ff)return + xcd=matmul(prot,xcd) + xc =matmul(prot,xc ) + call ctog(xc,glat(ix,iy),glon(ix,iy)) + enddo +enddo + +! Convert degrees to radians in the glat and glon arrays: +glat=glat*dtor +glon=glon*dtor + +! 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 +! Convert the areas to area units consistent with the length units used for +! the radius, re, of the sphere: +rre=re*re +garea=garea*rre + +end subroutine hgrid_ak diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/pietc.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/pietc.f90 new file mode 100644 index 000000000..f6abe1af3 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/pietc.f90 @@ -0,0 +1,95 @@ +! +!============================================================================= +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,u1=1,mu1=-u1,u2=2,mu2=-u2,u3=3,mu3=-u3,u4=4,mu4=-u4,u5=5,mu5=-u5, & + u6=6,mu6=-u6,o2=u1/2,o3=u1/3,o4=u1/4,o5=u1/5,o6=u1/6, & + 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/sorc/fre-nctools.fd/tools/regional_grid.fd/pkind.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/pkind.f90 new file mode 100644 index 000000000..abc5841b7 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/pkind.f90 @@ -0,0 +1,8 @@ +module pkind +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/sorc/fre-nctools.fd/tools/regional_grid.fd/pmat.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/pmat.f90 new file mode 100644 index 000000000..11f1b0f7b --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/pmat.f90 @@ -0,0 +1,1082 @@ +! +! ********************************************** +! * MODULE pmat * +! * R. J. Purser, NOAA/NCEP/EMC 1993 * +! * and Tsukasa Fujita, visiting scientist * +! * from JMA. * +! * Major modifications: 2002, 2009, 2012 * +! * jim.purser@noaa.gov * +! * * +! ********************************************** +! +! 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: 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) +!---------------- +real(sp),dimension(:,:),intent(inout):: a +logical, intent( out):: ff +integer :: m,i,j,jp,l +real(sp) :: d +integer,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)=1./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 :: m,i,j,jp,l +real(DP) :: d +integer, 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/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] +!============================================================================= +complex(dpc),dimension(:,:),intent(INOUT):: a +logical, intent( OUT):: ff +integer :: m,i,j,jp,l +complex(dpc) :: d +integer, 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)=1/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,dimension(size(a,1)) :: ipiv +integer :: 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, dimension(size(a,1)) :: ipiv +integer :: 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, dimension(size(a,1)) :: ipiv +integer :: 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,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, 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,dimension(:,:),intent(INOUT):: imat +logical, intent( OUT):: ff +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-10_dp +real(dp),dimension(size(imat,1),size(imat,1)):: dmat +integer :: 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, 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, 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, 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. +!============================================================================= +real(SP),intent(INOUT) :: a(:,:) +real(SP),intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: 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=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + print '("In sldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +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 == 0)then + jm=j-1 + print '(" failure in sldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=1/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] +!============================================================================= +real(DP), intent(INOUT) :: a(:,:) +real(DP), intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: 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=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + print '("In dldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +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 == 0)then + jm=j-1 + print '(" Failure in dldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=1/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: c0 +complex(dpc), intent(INOUT) :: a(:,:) +complex(dpc), intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: 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=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + print '("In cldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +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=1/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 +!============================================================================= +integer, dimension(:), intent(in) :: ipiv +real(sp),dimension(:,:),intent(in) :: a +real(sp),dimension(:,:),intent(inout) :: b +integer :: 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=1/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] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv +real(dp), dimension(:,:),intent(in ) :: a +real(dp), dimension(:,:),intent(inout) :: b +integer :: 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=1/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] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv +complex(dpc),dimension(:,:),intent(in ) :: a +complex(dpc),dimension(:,:),intent(inout) :: b +integer :: 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=1/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 +!============================================================================= +integer, dimension(:), intent(in) :: ipiv +real(sp),dimension(:,:),intent(in) :: a +real(sp),dimension(:), intent(inout) :: b +integer :: 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=1/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] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv(:) +real(dp), dimension(:,:),intent(in ) :: a(:,:) +real(dp), dimension(:), intent(inout) :: b(:) +integer :: 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=1/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] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv(:) +complex(dpc),dimension(:,:),intent(in ) :: a(:,:) +complex(dpc),dimension(:), intent(inout) :: b(:) +integer :: 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=1/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) +!============================================================================= +real(sp), intent(IN ) :: a(:,:) +real(sp), intent(INOUT) :: b(:,:) +logical :: ff +!----------------------------------------------------------------------------- +integer :: 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 <= 0) + if(ff)then + print '("sL1Lmf detects nonpositive a, rank=",i6)',jm + return + endif + b(j,j)=sqrt(s) + bjji=1/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) = 0 +enddo +end subroutine sl1lmf +!============================================================================= +subroutine dl1lmf(a,b,ff) ! [L1Lm] +!============================================================================= +real(dp), intent(IN ) :: a(:,:) +real(dp), intent(INOUT) :: b(:,:) +logical :: ff +!----------------------------------------------------------------------------- +integer :: 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 <= 0) + if(ff)then + print '("dL1LMF detects nonpositive A, rank=",i6)',jm + return + endif + b(j,j)=sqrt(s) + bjji=1/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) = 0 +enddo +return +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 +!============================================================================= +real(sp), intent(IN ):: a(:,:) +real(sp), intent(INOUT):: b(:,:) +real(sp), intent( OUT):: d(:) +logical, intent( OUT):: ff +!----------------------------------------------------------------------------- +integer :: 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) = 1 + ff=(d(j) == 0) + if(ff)then + print '("In sldlmf; singularity of matrix detected")' + print '("Rank of matrix: ",i6)',jm + return + endif + bjji=1/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)=0 +enddo +end subroutine sldlmf +!============================================================================= +subroutine dldlmf(a,b,d,ff) ! [LDLM] +!============================================================================= +! Modified Cholesky Q --> L*D*U, U(i,j)=L(j,i) +!============================================================================= +real(dp), intent(IN ) :: a(:,:) +real(dp), intent(INOUT) :: b(:,:) +real(dp), intent( OUT) :: d(:) +logical, intent( OUT) :: ff +!----------------------------------------------------------------------------- +integer :: 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) == 0) + if(ff)then + print '("In dldlmf; singularity of matrix detected")' + print '("Rank of matrix: ",i6)',jm + return + endif + bjji=1/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)=0 +enddo +end subroutine dldlmf + +!============================================================================== +subroutine sinvu(a)! [invu] +!============================================================================== +! Invert the upper triangular matrix in place by transposing, calling +! invl, and transposing again. +!============================================================================== +real,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 +!============================================================================== +real(sp), intent(inout) :: a(:,:) +integer :: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = 0.0 + a(j,j)=1./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] +!============================================================================== +real(dp), intent(inout) :: a(:,:) +integer :: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = 0.0 + a(j,j)=1./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, intent(in ) :: a(:,:) +real, intent(inout) :: u(:) +integer :: 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 :: 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, intent(in ) :: a(:,:) +real, intent(inout) :: u(:) +integer :: 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 :: 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/sorc/fre-nctools.fd/tools/regional_grid.fd/pmat4.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/pmat4.f90 new file mode 100644 index 000000000..8cb2fcb70 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/pmat4.f90 @@ -0,0 +1,1924 @@ +! +! ********************************************** +! * MODULE pmat4 * +! * R. J. Purser, NOAA/NCEP/EMC Oct 2005 * +! * 18th May 2012 * +! * jim.purser@noaa.gov * +! * * +! ********************************************** +! +! 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: 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; 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] +!============================================================================= +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] +!============================================================================= +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] +!============================================================================= +real(sp),dimension(:),intent(IN):: a +real(sp),dimension(size(a)) :: b +real(sp) :: s +s=absv_s(a); if(s==0)then; b=0;else;b=a/s;endif +end function normalized_s +!============================================================================= +function normalized_d(a)result(b)! [normalized] +!============================================================================= +real(dp),dimension(:),intent(IN):: a +real(dp),dimension(size(a)) :: b +real(dp) :: s +s=absv_d(a); if(s==0)then; b=0;else;b=a/s;endif +end function normalized_d + +!============================================================================= +function orthogonalized_s(u,a)result(b)! [orthogonalized] +!============================================================================= +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] +!============================================================================= +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] +!============================================================================= +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] +!============================================================================= +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 outer_product_s(a,b)result(c)! [outer_product] +!============================================================================= +real(sp),dimension(:), intent(in ):: a +real(sp),dimension(:), intent(in ):: b +real(sp),DIMENSION(size(a),size(b)):: c +integer :: 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] +!============================================================================= +real(dp),dimension(:), intent(in ):: a +real(dp),dimension(:), intent(in ):: b +real(dp),dimension(size(a),size(b)):: c +integer :: 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] +!============================================================================= +integer,dimension(:), intent(in ):: a +integer,dimension(:), intent(in ):: b +integer,dimension(size(a),size(b)):: c +integer :: 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] +!============================================================================= +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] +!============================================================================= +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] +!============================================================================= +real(sp),dimension(:,:),intent(IN ) ::a +real(sp) :: det +real(sp),dimension(size(a,1),size(a,1)):: b +integer :: 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(nranknrank)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)<0)s=-s + det=det*s + 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 gram_s + +!============================================================================= +subroutine gram_d(as,b,nrank,det)! [gram] +!============================================================================= +real(dp),dimension(:,:),intent(IN ) :: as +real(dp),dimension(:,:),intent(OUT) :: b +integer, intent(OUT) :: nrank +real(dp), intent(OUT) :: det +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(dp),parameter :: crit=1.e-9_dp +real(dp),dimension(size(as,1),size(as,2)):: a +real(dp),dimension(size(as,2),size(as,1)):: ab +real(dp),dimension(size(as,1)) :: tv,w +real(dp) :: val,s,vcrit +integer :: i,j,k,l,m,n +integer,dimension(2) :: ii +!============================================================================= +n=size(as,1) +m=size(as,2) +if(n/=size(b,1) .or. n/=size(b,2))stop 'In gram; incompatible dimensions' +a=as +b=identity(n) +det=1 +val=maxval(abs(a)) +if(val==0)then + nrank=0 + return +endif +vcrit=val*crit +nrank=min(n,m) +do k=1,n + if(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)<0)s=-s + det=det*s + 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 gram_d + +!============================================================================= +subroutine graml_d(as,b,nrank,detsign,ldet)! [gram] +!============================================================================= +! A version of gram_d where the determinant information is returned in +! logarithmic form (to avoid overflows for large matrices). When the +! matrix is singular, the "sign" of the determinant, detsign, is returned +! as zero (instead of either +1 or -1) and ldet is then just the log of +! the nonzero factors found by the process. +!============================================================================= +real(dp),dimension(:,:),intent(IN ) :: as +real(dp),dimension(:,:),intent(OUT) :: b +integer, intent(OUT) :: nrank +integer, intent(out) :: detsign +real(dp), intent(OUT) :: ldet +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(dp),parameter :: crit=1.e-9_dp +real(dp),dimension(size(as,1),size(as,2)):: a +real(dp),dimension(size(as,2),size(as,1)):: ab +real(dp),dimension(size(as,1)) :: tv,w +real(dp) :: val,s,vcrit +integer :: i,j,k,l,m,n +integer,dimension(2) :: ii +!============================================================================= +detsign=1 +n=size(as,1) +m=size(as,2) +if(n/=size(b,1) .or. n/=size(b,2))stop 'In gram; incompatible dimensions' +a=as +b=identity(n) +!det=1 +ldet=0 +val=maxval(abs(a)) +if(val==0)then + nrank=0 + return +endif +vcrit=val*crit +nrank=min(n,m) +do k=1,n + if(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)<0)s=-s + if(s<0)then + ldet=ldet+log(-s) + detsign=-detsign + elseif(s>0)then + ldet=ldet+log(s) + else + detsign=0 + endif + +! det=det*s + 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. +real(sp),dimension(:,:),intent(INOUT) :: b +integer, intent( OUT) :: nrank +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(sp),parameter :: crit=1.e-5_sp +real(sp) :: val,vcrit +integer :: 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=0 + return +endif +vcrit=val*crit +do k=1,n + val=sqrt(dot_product(b(:,k),b(:,k))) + if(val<=vcrit)then + b(:,k:n)=0 + 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. +real(dp),dimension(:,:),intent(INOUT) :: b +integer, intent( OUT) :: nrank +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(dp),parameter :: crit=1.e-9_dp +real(dp) :: val,vcrit +integer :: 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=0 + return +endif +vcrit=val*crit +do k=1,n + val=sqrt(dot_product(b(:,k),b(:,k))) + if(val<=vcrit)then + b(:,k:n)=0 + 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=0 +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=0 + 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(maxpu1(2))then + j=3 +else + j=2 +endif +ss=u1(j) +if(ss==0)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/2 + +! 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 +!============================================================================== +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 +!============================================================================= +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 +!============================================================================= +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] +!============================================================================= +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 +!============================================================================= +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: u1,u2,o2 +integer, 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,parameter :: L=5 +real(dp),dimension(n,n):: c,p +real(dp) :: t +integer :: i,m +!============================================================================= +m=10+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*2+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+1 +enddo +detb=0; 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: u1,u2,o2 +integer, 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,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 :: i,j,k,m,n1 +!============================================================================= +n1=(n*(n+1))/2 +m=10+log(u1+maxval(abs(a)))/log(u2) +t=o2**m +c=a*t +p=c +pd=0 +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*2+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+1 +enddo +detb=0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +detbd=0; 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: u1,u2,o2 +integer, 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,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 :: i,j,k,ki,kj,m,n1 +!============================================================================= +n1=(n*(n+1))/2 +m=10+log(u1+maxval(abs(a)))/log(u2) +t=o2**m +c=a*t +p=c +pd=0 +pdd=0 +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=0 +b=p +bd=pd +bdd=0 + +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)=2*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*2+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+1 +enddo +detb=0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +detbd=0; do k=1,n; detbd(k)=detb; enddo +detbdd=0; do ki=1,n; do kj=1,n; detbdd(ki,kj)=detb; enddo; enddo +end subroutine expmatdd + +!============================================================================= +subroutine zntay(n,z,zn)! [zntay] +!============================================================================= +integer, intent(IN ):: n +real(dp),intent(IN ):: z +real(dp),intent(OUT):: zn +!----------------------------------------------------------------------------- +integer,parameter :: ni=100 +real(dp),parameter :: eps0=1.e-16 +integer :: i,i2,n2 +real(dp) :: t,eps,z2 +!============================================================================= +z2=z*2 +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)0)then + zn=cosh(rz2) + znd=sinh(rz2)/rz2 + zndd=(zn-znd)/z2 + znddd=(znd-3*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-3*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] +!============================================================================= +real(dp),dimension(3),intent(IN ):: v +complex(dpc), intent(OUT):: z +logical, intent(OUT):: infz +!----------------------------------------------------------------------------- +real(dp),parameter:: zero=0,one=1 +real(dp) :: rr,zzpi +!============================================================================= +infz=.false. +z=cmplx(v(1),v(2),dpc) +if(v(3)>0)then + zzpi=one/(one+v(3)) +else + rr=v(1)**2+v(2)**2 + infz=(rr==zero); if(infz)return ! <- The point is mapped to infinity (90S) + zzpi=(one-v(3))/rr +endif +z=z*zzpi +end subroutine ctoz + +!============================================================================= +subroutine ztoc(z,infz, v)! [ztoc] +!============================================================================= +complex(dpc), intent(IN ):: z +logical, intent(IN ):: infz +real(dp),dimension(3),intent(OUT):: v +!----------------------------------------------------------------------------- +real(dp),parameter:: zero=0,one=1 +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)=2*rsbi*r +v(2)=2*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!!! +!============================================================================= +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,one=1 +real(dp) :: r,q,rs,rsc,rsbi,rsbis +real(dp),dimension(3):: u1,u2 +integer :: 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)=2*rsbi*r +v(2)=2*rsbi*q +v(3)=rsc*rsbi +u1(1)=2*(one+q*q-r*r)*rsbis +u1(2)=-4*r*q*rsbis +u1(3)=-4*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). +!============================================================================ +real(dp),dimension(3),intent(IN ):: xc0,xc1,xc2 +complex(dpc), intent(OUT):: aa,bb,cc,dd +!---------------------------------------------------------------------------- +real(dp),parameter:: zero=0,one=1 +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) XE three cartesian components. +! <-- DLAT degrees latitude +! <-- DLON degrees longitude +!============================================================================= +use pietc, only: u0,rtod +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 +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, only: dtor +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 +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] +!============================================================================= +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: dtor +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)=0 ; dxedlon=dxedlon*dtor +end subroutine dgtocd +!============================================================================= +subroutine sgtocdd(dlat,dlon,xe,dxedlat,dxedlon, & + ddxedlatdlat,ddxedlatdlon,ddxedlondlon)! [gtoc] +!============================================================================= +use pietc, only: dtor +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: dtor +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)=0 ; dxedlon=dxedlon*dtor +ddxedlatdlat(1)=-cla*clo +ddxedlatdlat(2)=-cla*slo +ddxedlatdlat(3)=-sla +ddxedlatdlon(1)= sla*slo +ddxedlatdlon(2)=-sla*clo +ddxedlatdlon(3)= 0 +ddxedlondlon(1)=-cla*clo +ddxedlondlon(2)=-cla*slo +ddxedlondlon(3)= 0 +ddxedlatdlat=ddxedlatdlat*dtor**2 +ddxedlatdlon=ddxedlatdlon*dtor**2 +ddxedlondlon=ddxedlondlon*dtor**2 +end subroutine dgtocdd + +!============================================================================== +subroutine sgtoframem(splat,splon,sorth)! [gtoframe] +!============================================================================== +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. +!============================================================================== +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] +!============================================================================== +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 +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] +!============================================================================== +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 +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] +!============================================================================== +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. +!============================================================================== +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 +!============================================================================= +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+1 +b=s-1 +ab2=a*b*2 +aa=a*a +bb=b*b +aapbb=aa+bb +aambb=aa-bb +d=aapbb-ab2*z +e=aapbb*z-ab2 +di=1/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. +!============================================================================= +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+1 +b=s-1 +ab2=a*b*2 +aa=a*a +bb=b*b +aapbb=aa+bb +aambb=aa-bb +d=aapbb-ab2*z +e=aapbb*z-ab2 +di=1/d +xc2(1)=(aambb*x)*di +xc2(2)=(aambb*y)*di +xc2(3)=e*di +ddi=di*di + +dxc2=0 +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. +!============================================================================= +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+1 +b=s-1 +ab2=a*b*2 +aa=a*a +bb=b*b +aapbb=aa+bb +aambb=aa-bb +d=aapbb-ab2*z +e=aapbb*z-ab2 +di=1/d +xc2(1)=(aambb*x)*di +xc2(2)=(aambb*y)*di +xc2(3)=e*di +ddi=di*di +dddi=ddi*di + +dxc2=0 +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=0 +ddxc2(1,1,3)=ab2*aambb*ddi +ddxc2(1,3,1)=ddxc2(1,1,3) +ddxc2(1,3,3)=2*ab2**2*aambb*x*dddi +ddxc2(2,2,3)=ab2*aambb*ddi +ddxc2(2,3,2)=ddxc2(2,2,3) +ddxc2(2,3,3)=2*ab2**2*aambb*y*dddi +ddxc2(3,3,3)=2*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 +!============================================================================= +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+1 +b=s-1 +ab2=a*b*2 +aa=a*a +bb=b*b +aapbb=aa+bb +aambb=aa-bb +d=aapbb-ab2*z +e=aapbb*z-ab2 +di=1/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. +!============================================================================= +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+1 +b=s-1 +ab2=a*b*2 +aa=a*a +bb=b*b +aapbb=aa+bb +aambb=aa-bb +d=aapbb-ab2*z +e=aapbb*z-ab2 +di=1/d +xc2(1)=(aambb*x)*di +xc2(2)=(aambb*y)*di +xc2(3)=e*di +ddi=di*di + +dxc2=0 +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. +!============================================================================= +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+1 +b=s-1 +ab2=a*b*2 +aa=a*a +bb=b*b +aapbb=aa+bb +aambb=aa-bb +d=aapbb-ab2*z +e=aapbb*z-ab2 +di=1/d +xc2(1)=(aambb*x)*di +xc2(2)=(aambb*y)*di +xc2(3)=e*di +ddi=di*di +dddi=ddi*di + +dxc2=0 +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=0 +ddxc2(1,1,3)=ab2*aambb*ddi +ddxc2(1,3,1)=ddxc2(1,1,3) +ddxc2(1,3,3)=2*ab2**2*aambb*x*dddi +ddxc2(2,2,3)=ab2*aambb*ddi +ddxc2(2,3,2)=ddxc2(2,2,3) +ddxc2(2,3,3)=2*ab2**2*aambb*y*dddi +ddxc2(3,3,3)=2*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 +!============================================================================= +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 +!============================================================================= +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 +!============================================================================= +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 +!============================================================================= +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 +!============================================================================= +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+1 +b=s-1 +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/sorc/fre-nctools.fd/tools/regional_grid.fd/psym2.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/psym2.f90 new file mode 100644 index 000000000..3b6459047 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/psym2.f90 @@ -0,0 +1,498 @@ +! *********************************** +! * module psym2 * +! * R. J. Purser * +! * NOAA/NCEP/EMC September 2018 * +! * jim.purser@noaa.gov * +! *********************************** +! +! 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. +! +! DIRECT DEPENDENCIES +! Module: pkind, pietc +! +!============================================================================= +module psym2 +!============================================================================= +use pkind, only: dp +use pietc, only: u0,u1,o2 +implicit none +private +public:: eigensym2,invsym2,sqrtsym2,expsym2,logsym2,id2222 + +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 logsym2d_e; module procedure logsym2d_e; end interface +interface logsym2d_t; module procedure logsym2d_t; end interface +interface id2222; module procedure id2222; 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. +!============================================================================= +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)/2; f=(a-c)/2 +h=sqrt(f**2+b**2) +g=sqrt(b**2+(h+abs(f))**2) +if (g==0)then; vv(:,1)=(/u1,u0/) +elseif(f> 0)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 flagg, 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. +!============================================================================= +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 :: 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). +!============================================================================= +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) +!============================================================================= +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:: 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 +!============================================================================= +real(dp),dimension(2,2),intent(in ):: em +real(dp),dimension(2,2),intent(out):: z +!----------------------------------------------------------------------------- +real(dp),dimension(2,2):: vv,oo +integer :: 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). +!============================================================================= +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)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] +!============================================================================= +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 :: 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=0; 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} +!============================================================================= +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,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 :: i,j,n +!============================================================================= +r=x; r(1,1)=x(1,1)-1; r(2,2)=x(2,2)-1 +z=0; 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)) Date: Fri, 2 Aug 2019 18:50:16 +0000 Subject: [PATCH 02/38] feature/regional_grid This commit references #66330. Update regional_grid build for Dell. Change-Id: Ibb5d58461a0dad36e2e4a47159178f20efac371c --- sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh b/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh index 698d4e186..33eb545ca 100755 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh @@ -12,7 +12,8 @@ case $1 in export FFLAGS="-O2 -g ${NETCDF_FFLAGS} ${NETCDF_LDFLAGS_F}" ;; "wcoss_dell_p3" ) export FCMP=ifort - export FFLAGS="-O2 -g ${NETCDF_FFLAGS} ${NETCDF_LDFLAGS_F}" ;; + export FFLAGS="-O2 -g ${NETCDF_FFLAGS}" + export LIBS="${NETCDF_LDFLAGS_F} ${HDF5_LDFLAGS_F}" ;; "jet" ) export FCMP=ifort export FFLAGS="-O2 -g -I$NETCDF/include" From 6b5b80b04e677a0ebdb0d52505689f7ebde7203c Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 2 Aug 2019 19:11:28 +0000 Subject: [PATCH 03/38] feature/regional_grid This commit references #66330. Update regional_grid build for Phase 1/2. Change-Id: Ib631122bd94d7f8d1fafdedabd37561adc631f77 --- sorc/fre-nctools.fd/tools/regional_grid.fd/.gitignore | 3 +++ sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh | 3 ++- 2 files changed, 5 insertions(+), 1 deletion(-) create mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/.gitignore diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/.gitignore b/sorc/fre-nctools.fd/tools/regional_grid.fd/.gitignore new file mode 100644 index 000000000..d177f6269 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/.gitignore @@ -0,0 +1,3 @@ +regional_grid +*.mod +*.o diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh b/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh index 33eb545ca..b1d0fcad1 100755 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh @@ -9,7 +9,8 @@ case $1 in export LIBS=blah ;; "wcoss" ) export FCMP=ifort - export FFLAGS="-O2 -g ${NETCDF_FFLAGS} ${NETCDF_LDFLAGS_F}" ;; + export FFLAGS="-O2 -g ${NETCDF_FFLAGS}" + export LIBS="${NETCDF_LDFLAGS_F}" ;; "wcoss_dell_p3" ) export FCMP=ifort export FFLAGS="-O2 -g ${NETCDF_FFLAGS}" From 62be8300acac00d9c90d4556366a8c14775885e7 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 2 Aug 2019 19:34:07 +0000 Subject: [PATCH 04/38] feature/regional_grid This commit references #66330. Update regional_grid build for Cray. Change-Id: Ifa65e3cbddcc9955192699224d165e69858f9c29 --- sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh b/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh index b1d0fcad1..5a735aed7 100755 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh @@ -6,7 +6,7 @@ case $1 in "cray" ) export FCMP=ftn export FFLAGS="-O2 -g" - export LIBS=blah ;; + export LIBS=" " ;; "wcoss" ) export FCMP=ifort export FFLAGS="-O2 -g ${NETCDF_FFLAGS}" From 6e0f4d89c07594af0ccd51999f275675f59a8ce1 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 6 Aug 2019 19:37:15 +0000 Subject: [PATCH 05/38] feature/regional_grid This commit references #66330. Add option to run Jim Pursers regional grid code to the grid setup scripts. Change-Id: Id7b7d5ef6221f4b664be5104dfcf132a31a4ee7a --- driver_scripts/driver_grid.dell.sh | 8 +++- ush/fv3gfs_driver_grid.sh | 64 +++++++++++++++++++++++++++++- ush/fv3gfs_filter_topo.sh | 2 +- ush/fv3gfs_make_grid.sh | 28 +++++++++++++ 4 files changed, 98 insertions(+), 4 deletions(-) diff --git a/driver_scripts/driver_grid.dell.sh b/driver_scripts/driver_grid.dell.sh index 74f38b53a..84f4c8910 100644 --- a/driver_scripts/driver_grid.dell.sh +++ b/driver_scripts/driver_grid.dell.sh @@ -65,7 +65,7 @@ module list #----------------------------------------------------------------------- export res=96 -export gtype=regional # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=regional2 # 'uniform', 'stretch', 'nest', or 'regional' if [ $gtype = stretch ]; then export stretch_fac=1.5 # Stretching factor for the grid @@ -81,6 +81,12 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then export iend_nest=166 # Ending i-direction index of nest grid in parent tile supergrid export jend_nest=164 # Ending j-direction index of nest grid in parent tile supergrid export halo=3 +elif [ $gtype = regional2 ] ; then + export target_lon=-97.5 # Center longitude of grid + export target_lat=35.5 # Center latitude of grid + export idim=301 # Dimension of grid in 'i' direction + export jdim=200 # Dimension of grid in 'j' direction + export halo=3 fi #----------------------------------------------------------------------- diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh index 838552139..81eb12b7e 100755 --- a/ush/fv3gfs_driver_grid.sh +++ b/ush/fv3gfs_driver_grid.sh @@ -67,6 +67,13 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then else echo "Creating regional grid" fi +elif [ $gtype = regional2 ]; then + export target_lon=${target_lon:--97.5} + export target_lat=${target_lat:-35.5} + export idim=${idim:-200} + export jdim=${jdim:-200} + export halo=${halo:-3} + title=jpgrid else echo "Error: please specify grid type with 'gtype' as uniform, stretch, nest or regional" exit 9 @@ -390,6 +397,59 @@ elif [ $gtype = regional ]; then echo "Grid and orography files are now prepared for regional grid" +#---------------------------------------------------------------------------------- +#---------------------------------------------------------------------------------- + +elif [ $gtype = regional2 ]; then + + halop1=$(( halo + 1 )) + tile=7 + name=C${res}_${title} + grid_dir=$TMPDIR/${name}/grid + orog_dir=$TMPDIR/${name}/orog + filter_dir=$TMPDIR/${name}/filter_topo + rm -rf $TMPDIR/$name + mkdir -p $grid_dir $orog_dir $filter_dir + + $script_dir/fv3gfs_make_grid.sh $grid_dir + + $script_dir/fv3gfs_make_orog.sh $res $tile $grid_dir $orog_dir $script_dir $topo $TMPDIR + + $script_dir/fv3gfs_filter_topo.sh $res $grid_dir $orog_dir $filter_dir $cd4 $peak_fac $max_slope $n_del2_weak $script_dir + + cd $filter_dir + + echo $idim $jdim $halop1 \'$filter_dir/oro.C${res}.tile${tile}.nc\' \'$filter_dir/oro.C${res}.tile${tile}.shave.nc\' >input.shave.orog + echo $idim $jdim $halop1 \'$filter_dir/C${res}_grid.tile${tile}.nc\' \'$filter_dir/C${res}_grid.tile${tile}.shave.nc\' >input.shave.grid + + $APRUN $exec_dir/shave.x input.shave.orog.halo$halo + echo $idim $jdim $halo \'$filter_dir/C${res}_grid.tile${tile}.nc\' \'$filter_dir/C${res}_grid.tile${tile}.shave.nc\' >input.shave.grid.halo$halo + + $APRUN $exec_dir/shave.x input.shave.orog.halo0 + echo $idim $jdim 0 \'$filter_dir/C${res}_grid.tile${tile}.nc\' \'$filter_dir/C${res}_grid.tile${tile}.shave.nc\' >input.shave.grid.halo0 + + $APRUN $exec_dir/shave.x ./regional_grid.nml << EOF + ®ional_grid_nml + plon = ${target_lon} + plat = ${target_lat} + delx = 0.0585 + dely = 0.0585 + lx = -${lx} + ly = -${ly} + a = 0.21423 + k = -0.23209 + / +EOF + + executable=$exec_dir/regional_grid + $APRUN $executable + fi if [ $? -ne 0 ]; then @@ -132,6 +155,11 @@ elif [ $gtype = regional ];then $APRUN $executable --num_tiles $ntiles --dir $outdir --mosaic C${res}_mosaic --tile_file C${res}_grid.tile7.nc +elif [ $gtype = regional2 ]; then + + mv regional_grid.nc C${res}_grid.tile7.nc + $APRUN $executable --num_tiles 1 --dir $outdir --mosaic C${res}_mosaic --tile_file C${res}_grid.tile7.nc + fi if [ $? -ne 0 ]; then From ede685e64a0c2134f1c3bb99acaaa275e194c36f Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 7 Aug 2019 13:42:14 +0000 Subject: [PATCH 06/38] feature/regional_grid This commit references #66330. Pass additional fields from grid driver required for JP regional grid. Change-Id: I8b1280f8788d0b2c3f4e8bb5d28e39cd599e64c6 --- driver_scripts/driver_grid.dell.sh | 12 +++++++++++- ush/fv3gfs_driver_grid.sh | 20 +++++++++++++++----- ush/fv3gfs_make_grid.sh | 16 ++++++++++------ 3 files changed, 36 insertions(+), 12 deletions(-) diff --git a/driver_scripts/driver_grid.dell.sh b/driver_scripts/driver_grid.dell.sh index 84f4c8910..f34a6f2ba 100644 --- a/driver_scripts/driver_grid.dell.sh +++ b/driver_scripts/driver_grid.dell.sh @@ -86,7 +86,17 @@ elif [ $gtype = regional2 ] ; then export target_lat=35.5 # Center latitude of grid export idim=301 # Dimension of grid in 'i' direction export jdim=200 # Dimension of grid in 'j' direction - export halo=3 + export delx=0.0585 # Grid spacing (in degrees) in the 'i' direction + # on the SUPERGRID (which has twice the resolution of + # the model grid). The physical grid spacing in the 'i' + # direction is related to delx as follows: + # distance = 2*delx*(circumf_Earth/360 deg) + export dely=0.0585 # Grid spacing (in degrees) in the 'j' direction. + export a_param=0.21423 # 'a' parameter of the generalized gnomonic mapping + # centered at target_lon/lat. See Purser office note. + export k_param=-0.23209 # 'k' parameter of the generalized gnomonic mapping + # centered at target_lon/lat. See Purser office note. + export halo=3 # number of row/cols for halo fi #----------------------------------------------------------------------- diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh index 81eb12b7e..420cfbb9f 100755 --- a/ush/fv3gfs_driver_grid.sh +++ b/ush/fv3gfs_driver_grid.sh @@ -68,11 +68,21 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then echo "Creating regional grid" fi elif [ $gtype = regional2 ]; then - export target_lon=${target_lon:--97.5} - export target_lat=${target_lat:-35.5} - export idim=${idim:-200} - export jdim=${jdim:-200} - export halo=${halo:-3} + export target_lon=${target_lon:--97.5} # Center longitude of grid + export target_lat=${target_lat:-35.5} # Center latitude of grid + export idim=${idim:-200} # Dimension of grid in 'i' direction + export jdim=${jdim:-200} # Dimension of grid in 'j' direction + export delx=${delx:-0.0585} # Grid spacing (in degrees) in the 'i' direction + # on the SUPERGRID (which has twice the resolution of + # the model grid). The physical grid spacing in the 'i' + # direction is related to delx as follows: + # distance = 2*delx*(circumf_Earth/360 deg) + export dely=${dely:-0.0585} # Grid spacing (in degrees) in the 'j' direction. + export a_param=${a_param:-0.21423} # 'a' parameter of the generalized gnomonic mapping + # centered at target_lon/lat. See Purser office note. + export k_param=${k_param:--0.23209} # 'k' parameter of the generalized gnomonic mapping + # centered at target_lon/lat. See Purser office note. + export halo=${halo:-3} # Number of rows/cols for halo. title=jpgrid else echo "Error: please specify grid type with 'gtype' as uniform, stretch, nest or regional" diff --git a/ush/fv3gfs_make_grid.sh b/ush/fv3gfs_make_grid.sh index f56bc348b..eef4e704c 100755 --- a/ush/fv3gfs_make_grid.sh +++ b/ush/fv3gfs_make_grid.sh @@ -39,7 +39,12 @@ nx=`expr $res \* 2 ` if [ ! -s $outdir ]; then mkdir -p $outdir ;fi cd $outdir -executable=$exec_dir/make_hgrid +if [ $gtype = regional2 ]; then + executable=$exec_dir/regional_grid +else + executable=$exec_dir/make_hgrid +fi + if [ ! -s $executable ]; then set +x echo @@ -93,16 +98,15 @@ elif [ $gtype = regional2 ] ; then ®ional_grid_nml plon = ${target_lon} plat = ${target_lat} - delx = 0.0585 - dely = 0.0585 + delx = ${delx} + dely = ${dely} lx = -${lx} ly = -${ly} - a = 0.21423 - k = -0.23209 + a = ${a_param} + k = ${k_param} / EOF - executable=$exec_dir/regional_grid $APRUN $executable fi From 19ba38309e45d05cd198e649ea1da9acb48b19a5 Mon Sep 17 00:00:00 2001 From: jeff beck Date: Mon, 12 Aug 2019 17:45:24 +0000 Subject: [PATCH 07/38] Changes to JPgrid to generate grid indices in the same manner as GFDLgrid --- sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 index 5f9f66473..389f53a69 100644 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 @@ -58,10 +58,13 @@ subroutine hgrid_ak(lx,ly,nx,ny,a,k,plat,plon,pazi, & 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 +!This code assumes symmetry about the grid center do iy=ly,my - xm(2)=iy*dely/re + !xm(2)=iy*dely/re + xm(2)=-iy*dely/re do ix=lx,mx - xm(1)=ix*delx/re + !xm(1)=ix*delx/re + xm(1)=-ix*delx/re call xmtoxc_ak(a,k,xm,xc,xcd,ff) if(ff)return xcd=matmul(prot,xcd) From fed5e6520e3a7c49cc96583d000637ee7e16fada Mon Sep 17 00:00:00 2001 From: George Gayno Date: Mon, 12 Aug 2019 20:44:56 +0000 Subject: [PATCH 08/38] feature/regional_grid This commit references #66330. Update driver grid scripts for jet and theia. Change-Id: I13b7218bdeeb7480ac85d5e51b11632be25a0c14 --- driver_scripts/driver_grid.jet.sh | 22 +++++++++++++++++++--- driver_scripts/driver_grid.theia.sh | 18 +++++++++++++++++- 2 files changed, 36 insertions(+), 4 deletions(-) diff --git a/driver_scripts/driver_grid.jet.sh b/driver_scripts/driver_grid.jet.sh index 0f7ca77b0..785ed557c 100644 --- a/driver_scripts/driver_grid.jet.sh +++ b/driver_scripts/driver_grid.jet.sh @@ -1,13 +1,13 @@ #!/bin/bash #SBATCH -J fv3_grid_driver -#SBATCH -A emcda +#SBATCH -A hfv3gfs #SBATCH --open-mode=truncate #SBATCH -o log.fv3_grid_driver #SBATCH -e log.fv3_grid_driver #SBATCH --nodes=1 --ntasks-per-node=24 #SBATCH --partition=xjet -#SBATCH -q windfall +#SBATCH -q batch #SBATCH -t 00:10:00 #----------------------------------------------------------------------- @@ -66,7 +66,7 @@ module list #----------------------------------------------------------------------- export res=96 -export gtype=regional # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=regional2 # 'uniform', 'stretch', 'nest', or 'regional' if [ $gtype = stretch ]; then export stretch_fac=1.5 # Stretching factor for the grid @@ -82,6 +82,22 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then export iend_nest=166 # Ending i-direction index of nest grid in parent tile supergrid export jend_nest=164 # Ending j-direction index of nest grid in parent tile supergrid export halo=3 # Lateral boundary halo +elif [ $gtype = regional2 ] ; then + export target_lon=-97.5 # Center longitude of grid + export target_lat=35.5 # Center latitude of grid + export idim=301 # Dimension of grid in 'i' direction + export jdim=200 # Dimension of grid in 'j' direction + export delx=0.0585 # Grid spacing (in degrees) in the 'i' direction + # on the SUPERGRID (which has twice the resolution of + # the model grid). The physical grid spacing in the 'i' + # direction is related to delx as follows: + # distance = 2*delx*(circumf_Earth/360 deg) + export dely=0.0585 # Grid spacing (in degrees) in the 'j' direction. + export a_param=0.21423 # 'a' parameter of the generalized gnomonic mapping + # centered at target_lon/lat. See Purser office note. + export k_param=-0.23209 # 'k' parameter of the generalized gnomonic mapping + # centered at target_lon/lat. See Purser office note. + export halo=3 # number of row/cols for halo fi #----------------------------------------------------------------------- diff --git a/driver_scripts/driver_grid.theia.sh b/driver_scripts/driver_grid.theia.sh index 88096511d..2aa7693bb 100644 --- a/driver_scripts/driver_grid.theia.sh +++ b/driver_scripts/driver_grid.theia.sh @@ -64,7 +64,7 @@ module list #----------------------------------------------------------------------- export res=96 -export gtype=uniform # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=regional2 # 'uniform', 'stretch', 'nest', or 'regional' if [ $gtype = stretch ]; then export stretch_fac=1.5 # Stretching factor for the grid @@ -80,6 +80,22 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then export iend_nest=166 # Ending i-direction index of nest grid in parent tile supergrid export jend_nest=164 # Ending j-direction index of nest grid in parent tile supergrid export halo=3 # Lateral boundary halo +elif [ $gtype = regional2 ] ; then + export target_lon=-97.5 # Center longitude of grid + export target_lat=35.5 # Center latitude of grid + export idim=301 # Dimension of grid in 'i' direction + export jdim=200 # Dimension of grid in 'j' direction + export delx=0.0585 # Grid spacing (in degrees) in the 'i' direction + # on the SUPERGRID (which has twice the resolution of + # the model grid). The physical grid spacing in the 'i' + # direction is related to delx as follows: + # distance = 2*delx*(circumf_Earth/360 deg) + export dely=0.0585 # Grid spacing (in degrees) in the 'j' direction. + export a_param=0.21423 # 'a' parameter of the generalized gnomonic mapping + # centered at target_lon/lat. See Purser office note. + export k_param=-0.23209 # 'k' parameter of the generalized gnomonic mapping + # centered at target_lon/lat. See Purser office note. + export halo=3 # number of row/cols for halo fi #----------------------------------------------------------------------- From b01274bd249804535038930ceb151532317b5f41 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 16 Aug 2019 13:16:28 +0000 Subject: [PATCH 09/38] feature/regional_grid: This commit references #66330. Updates to run JP grid on WCOSS-Cray. Change-Id: I9c3b0a426a22a672c8c140622fd5d5174f8c2069 --- driver_scripts/driver_grid.cray.sh | 18 +++++++++- ush/fv3gfs_driver_grid.sh | 55 ++++++++++++++++++++++++++++-- 2 files changed, 69 insertions(+), 4 deletions(-) diff --git a/driver_scripts/driver_grid.cray.sh b/driver_scripts/driver_grid.cray.sh index ec813e9f3..2059aa862 100644 --- a/driver_scripts/driver_grid.cray.sh +++ b/driver_scripts/driver_grid.cray.sh @@ -58,7 +58,7 @@ module list #----------------------------------------------------------------------- export res=96 -export gtype=regional # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=uniform # 'uniform', 'stretch', 'nest', or 'regional' if [ $gtype = stretch ]; then export stretch_fac=1.5 # Stretching factor for the grid @@ -74,6 +74,22 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then export iend_nest=166 # Ending i-direction index of nest grid in parent tile supergrid export jend_nest=164 # Ending j-direction index of nest grid in parent tile supergrid export halo=3 +elif [ $gtype = regional2 ] ; then + export target_lon=-97.5 # Center longitude of grid + export target_lat=35.5 # Center latitude of grid + export idim=301 # Dimension of grid in 'i' direction + export jdim=200 # Dimension of grid in 'j' direction + export delx=0.0585 # Grid spacing (in degrees) in the 'i' direction + # on the SUPERGRID (which has twice the resolution of + # the model grid). The physical grid spacing in the 'i' + # direction is related to delx as follows: + # distance = 2*delx*(circumf_Earth/360 deg) + export dely=0.0585 # Grid spacing (in degrees) in the 'j' direction. + export a_param=0.21423 # 'a' parameter of the generalized gnomonic mapping + # centered at target_lon/lat. See Purser office note. + export k_param=-0.23209 # 'k' parameter of the generalized gnomonic mapping + # centered at target_lon/lat. See Purser office note. + export halo=3 # number of row/cols for halo fi #----------------------------------------------------------------------- diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh index 420cfbb9f..539b1ce1c 100755 --- a/ush/fv3gfs_driver_grid.sh +++ b/ush/fv3gfs_driver_grid.sh @@ -19,7 +19,7 @@ # # Calls the following scripts: # 1) fv3gfs_make_grid.sh (make 'grid' files) -# 2) fv3gfs_maske_orog.sh (make 'oro' files) +# 2) fv3gfs_mask_orog.sh (make 'oro' files) # 3) fv3gfs_filter_topo.sh (filter topography) # 4) sfc_climo_gen.sh (create surface climo fields) # @@ -192,6 +192,10 @@ if [ $gtype = uniform ] || [ $gtype = stretch ] || [ $gtype = nest ]; then tile=$(( $tile + 1 )) done aprun -j 1 -n 4 -N 4 -d 6 -cc depth cfp $TMPDIR/orog.file1 + err=$? + if [ $err != 0 ]; then + exit $err + fi rm $TMPDIR/orog.file1 else tile=1 @@ -202,6 +206,10 @@ if [ $gtype = uniform ] || [ $gtype = stretch ] || [ $gtype = nest ]; then echo set -x $script_dir/fv3gfs_make_orog.sh $res $tile $grid_dir $orog_dir $script_dir $topo $TMPDIR + err=$? + if [ $err != 0 ]; then + exit $err + fi tile=$(( $tile + 1 )) done fi @@ -331,6 +339,7 @@ elif [ $gtype = regional ]; then if [ $machine = WCOSS_C ]; then echo "$script_dir/fv3gfs_make_orog.sh $res 7 $grid_dir $orog_dir $script_dir $topo $TMPDIR " >>$TMPDIR/orog.file1 aprun -j 1 -n 4 -N 4 -d 6 -cc depth cfp $TMPDIR/orog.file1 + err=$? rm $TMPDIR/orog.file1 else set +x @@ -339,11 +348,15 @@ elif [ $gtype = regional ]; then echo set -x $script_dir/fv3gfs_make_orog.sh $res $tile $grid_dir $orog_dir $script_dir $topo $TMPDIR + err=$? + fi + if [ $err != 0 ]; then + exit $err fi set +x echo - echo "............ Execute fv3gfs_filter_topo.sh .............." + echo "............ Execute fv3gfs_filter_topo.sh .............." echo set -x $script_dir/fv3gfs_filter_topo.sh $res $grid_dir $orog_dir $filter_dir $cd4 $peak_fac $max_slope $n_del2_weak $script_dir @@ -421,11 +434,47 @@ elif [ $gtype = regional2 ]; then rm -rf $TMPDIR/$name mkdir -p $grid_dir $orog_dir $filter_dir + set +x + echo + echo "............ Execute fv3gfs_make_grid.sh ................." + echo + set -x $script_dir/fv3gfs_make_grid.sh $grid_dir + err=$? + if [ $err != 0 ]; then + exit $err + fi - $script_dir/fv3gfs_make_orog.sh $res $tile $grid_dir $orog_dir $script_dir $topo $TMPDIR + echo "Begin orography generation at `date`" + +#---------------------------------------------------------------------------------- +# On WCOSS_C use cfp to run multiple tiles simulatneously for the orography. +# For now we only have one tile but in the future we will have more. +#---------------------------------------------------------------------------------- + + if [ $machine = WCOSS_C ]; then + echo "$script_dir/fv3gfs_make_orog.sh $res $tile $grid_dir $orog_dir $script_dir $topo $TMPDIR " >>$TMPDIR/orog.file1 + aprun -j 1 -n 4 -N 4 -d 6 -cc depth cfp $TMPDIR/orog.file1 + err=$? + rm $TMPDIR/orog.file1 + else + set +x + echo + echo "............ Execute fv3gfs_make_orog.sh for tile $tile .................." + echo + set -x + $script_dir/fv3gfs_make_orog.sh $res $tile $grid_dir $orog_dir $script_dir $topo $TMPDIR + err=$? + fi + if [ $err != 0 ]; then + exit $err + fi $script_dir/fv3gfs_filter_topo.sh $res $grid_dir $orog_dir $filter_dir $cd4 $peak_fac $max_slope $n_del2_weak $script_dir + err=$? + if [ $err != 0 ]; then + exit $err + fi cd $filter_dir From 8878bd1f8cbbc230244a511912ecb977aff6d481 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 13 Mar 2020 12:35:46 +0000 Subject: [PATCH 10/38] feature/regional_grid This commit references #4. Update ./fre-nctools.fd/tools/regional_grid.fd/build.sh for Hera. --- sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh b/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh index 5a735aed7..e9fa48b7d 100755 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh @@ -19,7 +19,7 @@ case $1 in export FCMP=ifort export FFLAGS="-O2 -g -I$NETCDF/include" export LIBS="-L$NETCDF/lib -lnetcdff -lnetcdf -L${HDF5}/lib -lhdf5 -lhdf5_fortran" ;; - "theia" ) + "hera" ) export FCMP=ifort export FFLAGS="-O2 -g -I$NETCDF/include" export LIBS="-L$NETCDF/lib -lnetcdff -lnetcdf -L${HDF5}/lib -lhdf5 -lhdf5_fortran" ;; From 27f57f8fe9af59b0ad4397c99d013a4696cbcdf0 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Fri, 13 Mar 2020 19:24:54 +0000 Subject: [PATCH 11/38] feature/regional_grid This commit references #4. Add Gerard's method to compute the global equivalent resolution for a regional grid to filter_topo.F90. Added as new routine "global_equiv_resol". --- .../tools/filter_topo/filter_topo.F90 | 173 +++++++++++++++++- 1 file changed, 172 insertions(+), 1 deletion(-) diff --git a/sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 b/sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 index 309eb9b34..71a7cd382 100644 --- a/sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 +++ b/sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 @@ -63,6 +63,7 @@ program filter_topo !--- compute filter constants for the regional resolution if(regional)then + call global_equiv_resol call compute_filter_constants endif @@ -1146,7 +1147,7 @@ subroutine two_delta_filter(is, ie, js, je, isd, ied, jsd, jed, npx, npy, ntiles real:: a1(is-1:ie+2) real:: a2(is:ie,js-1:je+2) real:: a3(is:ie,js:je,ntiles) - real:: smax, smin, m_slope, fac + real:: smax, m_slope, fac integer:: i,j, nt, t integer:: is1, ie2, js1, je2 @@ -1763,6 +1764,173 @@ subroutine read_namelist end subroutine read_namelist +!======================================================================= +! Determine the global equivalent resolution for a jim purser +! regional grid. +!======================================================================= + + subroutine global_equiv_resol + + use netcdf + + implicit none + + integer, parameter :: dp = kind(1.0d0) + real(dp), parameter :: pi_geom = 4.0*atan(1.0), & + radius_Earth = 6371000.0 + + character(len=50) :: tile_file + integer :: ncid, nxSG_dimid, nySG_dimid, dASG_varid + integer :: nxSG, nySG, nx, ny, RES_equiv, id_var + real(dp) :: avg_cell_size, min_cell_size, max_cell_size + real(dp), dimension(:,:), allocatable :: & + quarter_dA_ll, quarter_dA_lr, quarter_dA_ur, quarter_dA_ul, & + dASG, dA, sqrt_dA + + WRITE(*,500) + WRITE(*,500) "Compute global equivalent resolution." + WRITE(*,500) "Opening NetCDF mosaic file for reading:" + WRITE(*,500) " file=", trim(grid_file) + +!======================================================================= +! Obtain the grid file name from the mosaic file. +!======================================================================= + + call check( nf90_open(trim(grid_file), NF90_NOWRITE, ncid) ) + + call check( nf90_inq_varid(ncid, 'gridfiles', id_var) ) + + call check ( nf90_get_var(ncid, id_var, tile_file ) ) + + call check ( nf90_close(ncid) ) +! +!======================================================================= +! +! Open the grid file and read in the dimensions of the supergrid. The +! supergrid is a grid that has twice the resolution of the actual/compu- +! tational grid. In the file, the names of the supergrid dimensions are +! nx and ny. Here, however, we reserve those names for the dimensions +! of the actual grid (since in the FV3 code and in other data files, nx +! and ny are used to denote the dimensions of the actual grid) and in- +! stead use the variables nxSG and nySG to denote the dimensions of the +! supergrid. +! +!======================================================================= +! + WRITE(*,500) + WRITE(*,500) "Opening NetCDF grid file for reading:" + WRITE(*,500) " file=", trim(tile_file) + + call check( nf90_open(trim(tile_file), NF90_NOWRITE, ncid) ) + + call check( nf90_inq_dimid(ncid, "nx", nxSG_dimid) ) + call check( nf90_inquire_dimension(ncid, nxSG_dimid, len=nxSG) ) + + call check( nf90_inq_dimid(ncid, "ny", nySG_dimid) ) + call check( nf90_inquire_dimension(ncid, nySG_dimid, len=nySG) ) + + WRITE(*,500) + WRITE(*,500) "Dimensions of supergrid are:" + WRITE(*,520) " nxSG = ", nxSG + WRITE(*,520) " nySG = ", nySG +! +!======================================================================= +! +! Read in the cell areas on the supergrid. Then add the areas of the +! four supergrid cells that make up one grid cell to obtain the cell +! areas on the actual grid. +! +!======================================================================= +! + allocate(dASG(0:nxSG-1, 0:nySG-1)) + call check( nf90_inq_varid(ncid, "area", dASG_varid) ) + call check( nf90_get_var(ncid, dASG_varid, dASG) ) + + call check ( nf90_close(ncid) ) + + nx = nxSG/2 + ny = nySG/2 + + WRITE(*,500) + WRITE(*,500) "Dimensions of (actual, i.e. computational) grid are:" + WRITE(*,520) " nx = ", nx + WRITE(*,520) " ny = ", ny + + allocate(quarter_dA_ll(0:nx-1, 0:ny-1)) + allocate(quarter_dA_lr(0:nx-1, 0:ny-1)) + allocate(quarter_dA_ul(0:nx-1, 0:ny-1)) + allocate(quarter_dA_ur(0:nx-1, 0:ny-1)) + + quarter_dA_ll = dASG(0:nxSG-1:2, 0:nySG-1:2) + quarter_dA_lr = dASG(0:nxSG-1:2, 1:nySG-1:2) + quarter_dA_ur = dASG(1:nxSG-1:2, 1:nySG-1:2) + quarter_dA_ul = dASG(1:nxSG-1:2, 0:nySG-1:2) + + deallocate(dASG) + + allocate(dA(0:nx-1, 0:ny-1)) + allocate(sqrt_dA(0:nx-1, 0:ny-1)) + + dA = quarter_dA_ll + quarter_dA_lr + quarter_dA_ur + quarter_dA_ul + + deallocate(quarter_dA_ll, quarter_dA_lr, quarter_dA_ur, quarter_dA_ul) + +!======================================================================= +! +! Calculate a typical/representative cell size for each cell by taking +! the square root of the area of the cell. Then calculate the minimum, +! maximum, and average cell sizes over the whole grid. +! +!======================================================================= +! + sqrt_dA = sqrt(dA) + deallocate(dA) + min_cell_size = minval(sqrt_dA) + max_cell_size = maxval(sqrt_dA) + avg_cell_size = sum(sqrt_dA)/(nx*ny) + deallocate(sqrt_dA) + + WRITE(*,500) + WRITE(*,500) "Minimum, maximum, and average cell sizes are (based on square" + WRITE(*,500) "root of cell area):" + WRITE(*,530) " min_cell_size = ", min_cell_size + WRITE(*,530) " max_cell_size = ", max_cell_size + WRITE(*,530) " avg_cell_size = ", avg_cell_size +! +!======================================================================= +! +! Use the average cell size to calculate an equivalent global uniform +! cubed-sphere resolution (in units of number of cells) for the regional +! grid. This is the RES that a global uniform (i.e. stretch factor of +! 1) cubed-sphere grid would need to have in order to have the same no- +! minal cell size as the average cell size of the regional grid. +! +!======================================================================= +! + RES_equiv = nint( (2.0*pi_geom*radius_Earth)/(4.0*avg_cell_size) ) + + WRITE(*,500) + WRITE(*,500) "Equivalent global uniform cubed-sphere resolution is:" + WRITE(*,530) " RES_equiv = ", RES_equiv + + 500 FORMAT(A) + 520 FORMAT(A, I7) + 530 FORMAT(A, G) + + end subroutine global_equiv_resol + + subroutine check(status) + use netcdf + integer,intent(in) :: status +! + if(status /= nf90_noerr) then + write(0,*) ' check netcdf status = ', status + write(0,'("error ", a)') trim(nf90_strerror(status)) + write(0,*) "Stopped" + stop 4 + endif + end subroutine check + !####################################################################### ! compute resolution-dependent values for the filtering. @@ -1808,6 +1976,9 @@ subroutine compute_filter_constants enddo endif + print* + print*,'global cres equival, toms method ',res_regional + n_del2_weak = nint(n_del2_weak_vals(index1)+factor*(n_del2_weak_vals(index2)-n_del2_weak_vals(index1))) cd4 = cd4_vals(index1)+factor*(cd4_vals(index2)-cd4_vals(index1)) max_slope = max_slope_vals(index1)+factor*(max_slope_vals(index2)-max_slope_vals(index1)) From 63f8a7a61c111f76f1982f24f8805b1176fb669a Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 31 Mar 2020 14:52:37 +0000 Subject: [PATCH 12/38] feature/regional_grid This commit references #4. Add global_equiv_resol as a separate code per Gerard's request. --- sorc/build_fre-nctools.sh | 9 + .../tools/global_equiv_resol.fd/Makefile | 24 +++ .../tools/global_equiv_resol.fd/build.sh | 40 ++++ .../global_equiv_resol.f90 | 185 ++++++++++++++++++ 4 files changed, 258 insertions(+) create mode 100644 sorc/fre-nctools.fd/tools/global_equiv_resol.fd/Makefile create mode 100755 sorc/fre-nctools.fd/tools/global_equiv_resol.fd/build.sh create mode 100644 sorc/fre-nctools.fd/tools/global_equiv_resol.fd/global_equiv_resol.f90 diff --git a/sorc/build_fre-nctools.sh b/sorc/build_fre-nctools.sh index c07414029..ab0142411 100755 --- a/sorc/build_fre-nctools.sh +++ b/sorc/build_fre-nctools.sh @@ -124,4 +124,13 @@ set -x cd $srcDir/tools/regional_grid.fd ./build.sh $system_site +set +x +echo "///////////////////////////////////////////////////////////////////////////" +echo "//////////////////////////////////////////////////////global_equiv_resol //" +echo "///////////////////////////////////////////////////////////////////////////" +set -x + +cd $srcDir/tools/global_equiv_resol.fd +./build.sh $system_site + exit diff --git a/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/Makefile b/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/Makefile new file mode 100644 index 000000000..d56fd9557 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/Makefile @@ -0,0 +1,24 @@ +SHELL := bash + +MAKEFLAGS += --warn-undefined-variables + +EXEC = global_equiv_resol + +.PHONY: all +all : $(EXEC) + +$(EXEC): global_equiv_resol.o + $(FC) $(FFLAGS) $(LIBS) -o $@ $^ + +.SUFFIXES: +.SUFFIXES: .f90 .o + +.f90.o: + $(FC) $(FFLAGS) -c $< + +.PHONY: clean +clean: + rm -f *.o *.mod $(EXEC) + +install: + cp $(EXEC) ../../../../exec diff --git a/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/build.sh b/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/build.sh new file mode 100755 index 000000000..f61225136 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/build.sh @@ -0,0 +1,40 @@ +#!/bin/sh + +set -x + +case $1 in + "cray" ) + export FC=ftn + export FFLAGS="-O2 -g" + export LIBS=" " ;; + "wcoss" ) + export FC=ifort + export FFLAGS="-O2 -g ${NETCDF_FFLAGS}" + export LIBS="${NETCDF_LDFLAGS_F}" ;; + "wcoss_dell_p3" ) + export FC=ifort + export FFLAGS="-O2 -g ${NETCDF_FFLAGS}" + export LIBS="${NETCDF_LDFLAGS_F} ${HDF5_LDFLAGS_F}" ;; + "jet" ) + export FC=ifort + export FFLAGS="-O2 -g -I$NETCDF/include" + export LIBS="-L$NETCDF/lib -lnetcdff -lnetcdf -L${HDF5}/lib -lhdf5 -lhdf5_fortran" ;; + "hera" ) + export FC=ifort + export FFLAGS="-O2 -g -I$NETCDF/include" + export LIBS="-L$NETCDF/lib -lnetcdff -lnetcdf -L${HDF5}/lib -lhdf5 -lhdf5_fortran" ;; + *) + echo "GLOBAL_EQUIV_RESOL UTILITY BUILD NOT TESTED ON MACHINE $1" + exit 1 ;; +esac + +make clean +make +make install + +if ((rc != 0)); then + echo "ERROR BUILDING GLOBAL_EQUIV_RESOL UTILITY" + exit $rc +else + exit 0 +fi diff --git a/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/global_equiv_resol.f90 b/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/global_equiv_resol.f90 new file mode 100644 index 000000000..7bd9c813f --- /dev/null +++ b/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/global_equiv_resol.f90 @@ -0,0 +1,185 @@ +!======================================================================= +program global_equiv_resol +!======================================================================= + + use netcdf + + implicit none + + integer, parameter :: dp = kind(1.0d0) + real(dp), parameter :: pi_geom = 4.0*atan(1.0), & + radius_Earth = 6371000.0 + + character(len=256) :: grid_fn + integer :: ncid, nxSG_dimid, nySG_dimid, dASG_varid, num_args + integer :: nxSG, nySG, nx, ny, RES_equiv + real(dp) :: avg_cell_size, min_cell_size, max_cell_size + real(dp), dimension(:,:), allocatable :: & + quarter_dA_ll, quarter_dA_lr, quarter_dA_ur, quarter_dA_ul, & + dASG, dA, sqrt_dA +! +!======================================================================= +! +! Read in the name of the file from the command line. The command-line +! call to this program should have exactly one argument consisting of +! the path to the NetCDF grid specification file to be read in. If this +! is not the case, print out a usage message and exit. +! +!======================================================================= +! + num_args = command_argument_count() + if (num_args == 1) then + call get_command_argument(1, grid_fn) + else + WRITE(*,500) + WRITE(*,500) "Exactly one argument must be specified to program global_equiv_resol." + WRITE(*,500) "Usage:" + WRITE(*,500) + WRITE(*,500) " global_equiv_resol path_to_grid_file" + WRITE(*,500) + WRITE(*,500) "where path_to_grid_file is the path to the NetCDF grid file. Actual " + WRITE(*,500) "number of specified command line arguments is:" + WRITE(*,510) " num_args = ", num_args + WRITE(*,500) "Stopping." +500 FORMAT(A) +510 FORMAT(A, I3) + STOP + end if +! +!======================================================================= +! +! Open the grid file and read in the dimensions of the supergrid. The +! supergrid is a grid that has twice the resolution of the actual/compu- +! tational grid. In the file, the names of the supergrid dimensions are +! nx and ny. Here, however, we reserve those names for the dimensions +! of the actual grid (since in the FV3 code and in other data files, nx +! and ny are used to denote the dimensions of the actual grid) and in- +! stead use the variables nxSG and nySG to denote the dimensions of the +! supergrid. +! +!======================================================================= +! + WRITE(*,500) + WRITE(*,500) "Opening NetCDF grid file for reading/writing:" + WRITE(*,500) " grid_fn = " // trim(grid_fn) + + call check( nf90_open(trim(grid_fn), NF90_WRITE, ncid) ) + + call check( nf90_inq_dimid(ncid, "nx", nxSG_dimid) ) + call check( nf90_inquire_dimension(ncid, nxSG_dimid, len=nxSG) ) + + call check( nf90_inq_dimid(ncid, "ny", nySG_dimid) ) + call check( nf90_inquire_dimension(ncid, nySG_dimid, len=nySG) ) + + WRITE(*,500) + WRITE(*,500) "Dimensions of supergrid are:" + WRITE(*,520) " nxSG = ", nxSG + WRITE(*,520) " nySG = ", nySG +520 FORMAT(A, I7) +! +!======================================================================= +! +! Read in the cell areas on the supergrid. Then add the areas of the +! four supergrid cells that make up one grid cell to obtain the cell +! areas on the actual grid. +! +!======================================================================= +! + allocate(dASG(0:nxSG-1, 0:nySG-1)) + call check( nf90_inq_varid(ncid, "area", dASG_varid) ) + call check( nf90_get_var(ncid, dASG_varid, dASG) ) + + nx = nxSG/2 + ny = nySG/2 + + WRITE(*,500) + WRITE(*,500) "Dimensions of (actual, i.e. computational) grid are:" + WRITE(*,520) " nx = ", nx + WRITE(*,520) " ny = ", ny + + allocate(quarter_dA_ll(0:nx-1, 0:ny-1)) + allocate(quarter_dA_lr(0:nx-1, 0:ny-1)) + allocate(quarter_dA_ul(0:nx-1, 0:ny-1)) + allocate(quarter_dA_ur(0:nx-1, 0:ny-1)) + + quarter_dA_ll = dASG(0:nxSG-1:2, 0:nySG-1:2) + quarter_dA_lr = dASG(0:nxSG-1:2, 1:nySG-1:2) + quarter_dA_ur = dASG(1:nxSG-1:2, 1:nySG-1:2) + quarter_dA_ul = dASG(1:nxSG-1:2, 0:nySG-1:2) + + allocate(dA(0:nx-1, 0:ny-1)) + allocate(sqrt_dA(0:nx-1, 0:ny-1)) + + dA = quarter_dA_ll + quarter_dA_lr + quarter_dA_ur + quarter_dA_ul +! +!======================================================================= +! +! Calculate a typical/representative cell size for each cell by taking +! the square root of the area of the cell. Then calculate the minimum, +! maximum, and average cell sizes over the whole grid. +! +!======================================================================= +! + sqrt_dA = sqrt(dA) + min_cell_size = minval(sqrt_dA) + max_cell_size = maxval(sqrt_dA) + avg_cell_size = sum(sqrt_dA)/(nx*ny) + + WRITE(*,500) + WRITE(*,500) "Minimum, maximum, and average cell sizes are (based on square" + WRITE(*,500) "root of cell area):" + WRITE(*,530) " min_cell_size = ", min_cell_size + WRITE(*,530) " max_cell_size = ", max_cell_size + WRITE(*,530) " avg_cell_size = ", avg_cell_size +530 FORMAT(A, G) +! +!======================================================================= +! +! Use the average cell size to calculate an equivalent global uniform +! cubed-sphere resolution (in units of number of cells) for the regional +! grid. This is the RES that a global uniform (i.e. stretch factor of +! 1) cubed-sphere grid would need to have in order to have the same no- +! minal cell size as the average cell size of the regional grid. +! +!======================================================================= +! + RES_equiv = nint( (2.0*pi_geom*radius_Earth)/(4.0*avg_cell_size) ) + + WRITE(*,500) + WRITE(*,500) "Equivalent global uniform cubed-sphere resolution is:" + WRITE(*,530) " RES_equiv = ", RES_equiv +! +!======================================================================= +! +! Write the average cell size and equivalent global resolution to the +! grid file as a global attributes. +! +!======================================================================= +! + WRITE(*,500) + WRITE(*,500) "Writing avg_cell_size and RES_equiv to the grid specification" + WRITE(*,500) "file as global attributes..." + + call check( nf90_redef(ncid) ) + call check( nf90_put_att(ncid, NF90_GLOBAL, "avg_cell_size", avg_cell_size) ) + call check( nf90_put_att(ncid, NF90_GLOBAL, "RES_equiv", RES_equiv) ) + call check( nf90_enddef(ncid) ) + + call check( nf90_close(ncid) ) + + WRITE(*,500) + WRITE(*,500) "Done." + +end program global_equiv_resol + + +subroutine check(status) + use netcdf + integer,intent(in) :: status +! + if(status /= nf90_noerr) then + write(0,*) ' check netcdf status = ', status + write(0,'("error ", a)') trim(nf90_strerror(status)) + stop "Stopped" + endif +end subroutine check From 3983efabf7a5d41e24143926e1e8ce78f21ed065 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 31 Mar 2020 21:10:20 +0000 Subject: [PATCH 13/38] feature/regional_grid This commit references #4. Add the "global_equiv_resol" step for JP grids. --- driver_scripts/driver_grid.dell.sh | 12 +++++++---- .../tools/global_equiv_resol.fd/.gitignore | 2 ++ ush/fv3gfs_driver_grid.sh | 20 +++++++++++++++++-- ush/fv3gfs_make_grid.sh | 16 +++++++++++++++ 4 files changed, 44 insertions(+), 6 deletions(-) create mode 100644 sorc/fre-nctools.fd/tools/global_equiv_resol.fd/.gitignore diff --git a/driver_scripts/driver_grid.dell.sh b/driver_scripts/driver_grid.dell.sh index 6ee39dd17..595146da4 100755 --- a/driver_scripts/driver_grid.dell.sh +++ b/driver_scripts/driver_grid.dell.sh @@ -64,14 +64,17 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export res=96 -export gtype=regional2 # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=regional # 'uniform', 'stretch', 'nest', or 'regional' -if [ $gtype = stretch ]; then +if [ $gtype = uniform ]; then + export res=96 +elif [ $gtype = stretch ]; then + export res=96 export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile export target_lat=35.5 # Center latitude of the highest resolution tile elif [ $gtype = nest ] || [ $gtype = regional ]; then + export res=96 export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile export target_lat=35.5 # Center latitude of the highest resolution tile @@ -82,6 +85,7 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then export jend_nest=164 # Ending j-direction index of nest grid in parent tile supergrid export halo=3 elif [ $gtype = regional2 ] ; then + export res=-999 # equivalent res is computed. export target_lon=-97.5 # Center longitude of grid export target_lat=35.5 # Center latitude of grid export idim=301 # Dimension of grid in 'i' direction @@ -108,7 +112,7 @@ fi export home_dir=$LS_SUBCWD/.. export TMPDIR=/gpfs/dell1/stmp/$LOGNAME/fv3_grid.$gtype -export out_dir=/gpfs/dell1/stmp/$LOGNAME/C${res} +export out_dir=/gpfs/dell1/stmp/$LOGNAME/my_grids #----------------------------------------------------------------------- # Should not need to change anything below here. diff --git a/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/.gitignore b/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/.gitignore new file mode 100644 index 000000000..8d61049d4 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/.gitignore @@ -0,0 +1,2 @@ +global_equiv_resol +global_equiv_resol.o diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh index 745987dcd..7aeda22d5 100755 --- a/ush/fv3gfs_driver_grid.sh +++ b/ush/fv3gfs_driver_grid.sh @@ -98,7 +98,7 @@ export exec_dir=$home_dir/exec export topo=$home_dir/fix/fix_orog rm -fr $TMPDIR -mkdir -p $out_dir $TMPDIR +mkdir -p $TMPDIR cd $TMPDIR ||exit 8 #---------------------------------------------------------------------------------------- @@ -121,7 +121,14 @@ elif [ $res -eq 1152 ]; then cd4=0.15; max_slope=0.16; n_del2_weak=20; peak_fac=1.0 elif [ $res -eq 3072 ]; then cd4=0.15; max_slope=0.30; n_del2_weak=24; peak_fac=1.0 +elif [ $res -eq -999 ]; then + set +x + echo "regional grid filter parameters will be computed later?" + set -x +# use the c768 values for now. + cd4=0.15; max_slope=0.12; n_del2_weak=16; peak_fac=1.0 else + set +x echo "grid C$res not supported, exit" exit 2 fi @@ -153,6 +160,8 @@ if [ $gtype = uniform ] || [ $gtype = stretch ] || [ $gtype = nest ]; then grid_dir=$TMPDIR/$name/grid orog_dir=$TMPDIR/$name/orog + out_dir=$out_dir/C${res} + mkdir -p $out_dir if [ $gtype = nest ]; then filter_dir=$orog_dir # nested grid topography will be filtered online @@ -312,6 +321,8 @@ elif [ $gtype = regional ]; then tile=7 rn=$( echo "$stretch_fac * 10" | bc | cut -c1-2 ) name=C${res}r${rn}n${refine_ratio}_${title} + out_dir=$out_dir/C${res} + mkdir -p $out_dir grid_dir=$TMPDIR/${name}/grid orog_dir=$TMPDIR/$name/orog filter_dir=$orog_dir # nested grid topography will be filtered online @@ -427,7 +438,7 @@ elif [ $gtype = regional2 ]; then halop1=$(( halo + 1 )) tile=7 - name=C${res}_${title} + name=regional grid_dir=$TMPDIR/${name}/grid orog_dir=$TMPDIR/${name}/orog filter_dir=$TMPDIR/${name}/filter_topo @@ -445,6 +456,11 @@ elif [ $gtype = regional2 ]; then exit $err fi + res=$( ncdump -h ${grid_dir}/C*_grid.tile7.nc | grep -o ":RES_equiv = [0-9]\+" | grep -o "[0-9]" ) + res=${res//$'\n'/} + out_dir=$out_dir/C${res} + mkdir -p $out_dir + echo "Begin orography generation at `date`" #---------------------------------------------------------------------------------- diff --git a/ush/fv3gfs_make_grid.sh b/ush/fv3gfs_make_grid.sh index eef4e704c..8f0a5a172 100755 --- a/ush/fv3gfs_make_grid.sh +++ b/ush/fv3gfs_make_grid.sh @@ -120,6 +120,20 @@ if [ $? -ne 0 ]; then exit 1 fi +if [ $gtype = regional2 ]; then + + $APRUN $exec_dir/global_equiv_resol regional_grid.nc + if [ $? -ne 0 ]; then + set +x + echo + echo "FATAL ERROR running global_equiv_resol." + echo + set -x + exit 2 + fi +fi + + #--------------------------------------------------------------------------------------- # Create mosaic file. # @@ -161,6 +175,8 @@ elif [ $gtype = regional ];then elif [ $gtype = regional2 ]; then + res=$( ncdump -h regional_grid.nc | grep -o ":RES_equiv = [0-9]\+" | grep -o "[0-9]" ) + res=${res//$'\n'/} mv regional_grid.nc C${res}_grid.tile7.nc $APRUN $executable --num_tiles 1 --dir $outdir --mosaic C${res}_mosaic --tile_file C${res}_grid.tile7.nc From 484c2f7ab83356a1b861e21c4701da06b8f60fc4 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 1 Apr 2020 12:51:41 +0000 Subject: [PATCH 14/38] feature/regional_grid This commit references #4. Update Cray grid driver script. --- driver_scripts/driver_grid.cray.sh | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/driver_scripts/driver_grid.cray.sh b/driver_scripts/driver_grid.cray.sh index 3c7a06be7..cc264d19b 100755 --- a/driver_scripts/driver_grid.cray.sh +++ b/driver_scripts/driver_grid.cray.sh @@ -51,20 +51,24 @@ . $MODULESHOME/init/sh module load PrgEnv-intel cfp-intel-sandybridge/1.1.0 +module load cray-netcdf module list #----------------------------------------------------------------------- # Set grid specs here. #----------------------------------------------------------------------- -export res=96 -export gtype=uniform # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=regional2 # 'uniform', 'stretch', 'nest', or 'regional' -if [ $gtype = stretch ]; then +if [ $gtype = uniform ]; then + export res=96 +elif [ $gtype = stretch ]; then + export res=96 export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile export target_lat=35.5 # Center latitude of the highest resolution tile elif [ $gtype = nest ] || [ $gtype = regional ]; then + export res=96 export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile export target_lat=35.5 # Center latitude of the highest resolution tile @@ -75,6 +79,7 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then export jend_nest=164 # Ending j-direction index of nest grid in parent tile supergrid export halo=3 elif [ $gtype = regional2 ] ; then + export res=-999 # equivalent res is computed. export target_lon=-97.5 # Center longitude of grid export target_lat=35.5 # Center latitude of grid export idim=301 # Dimension of grid in 'i' direction @@ -101,7 +106,7 @@ fi export home_dir=$LS_SUBCWD/.. export TMPDIR=/gpfs/hps3/stmp/$LOGNAME/fv3_grid.$gtype -export out_dir=/gpfs/hps3/stmp/$LOGNAME/C${res} +export out_dir=/gpfs/hps3/stmp/$LOGNAME/my_grids export NODES=1 export APRUN="aprun -n 1 -N 1 -j 1 -d 1 -cc depth" From dcbea2ca6853af2ea995c4aeaed142b91b3689fb Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 1 Apr 2020 13:05:42 +0000 Subject: [PATCH 15/38] feature/regional_grid This commit references #4. Update Hera grid driver script. --- driver_scripts/driver_grid.hera.sh | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/driver_scripts/driver_grid.hera.sh b/driver_scripts/driver_grid.hera.sh index 129c1f327..3d8e5c26e 100755 --- a/driver_scripts/driver_grid.hera.sh +++ b/driver_scripts/driver_grid.hera.sh @@ -63,14 +63,17 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export res=96 export gtype=regional2 # 'uniform', 'stretch', 'nest', or 'regional' -if [ $gtype = stretch ]; then +if [ $gtype = uniform ]; then + export res=96 +elif [ $gtype = stretch ]; then + export res=96 export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile export target_lat=35.5 # Center latitude of the highest resolution tile elif [ $gtype = nest ] || [ $gtype = regional ]; then + export res=96 export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile export target_lat=35.5 # Center latitude of the highest resolution tile @@ -81,6 +84,7 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then export jend_nest=164 # Ending j-direction index of nest grid in parent tile supergrid export halo=3 # Lateral boundary halo elif [ $gtype = regional2 ] ; then + export res=-999 # equivalent res is computed. export target_lon=-97.5 # Center longitude of grid export target_lat=35.5 # Center latitude of grid export idim=301 # Dimension of grid in 'i' direction @@ -107,7 +111,7 @@ fi export home_dir=$SLURM_SUBMIT_DIR/.. export TMPDIR=/scratch2/NCEPDEV/stmp1/$LOGNAME/fv3_grid.$gtype -export out_dir=/scratch2/NCEPDEV/stmp1/$LOGNAME/C${res} +export out_dir=/scratch2/NCEPDEV/stmp1/$LOGNAME/my_grids #----------------------------------------------------------------------- # Should not need to change anything below here. From 0a2ddb509937cb2acddbea7b5ef63d48d7df8167 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 1 Apr 2020 13:23:12 +0000 Subject: [PATCH 16/38] feature/regional_grid This commit references #4. Update Jet grid driver script. --- driver_scripts/driver_grid.jet.sh | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/driver_scripts/driver_grid.jet.sh b/driver_scripts/driver_grid.jet.sh index e243600fa..211adc2d2 100755 --- a/driver_scripts/driver_grid.jet.sh +++ b/driver_scripts/driver_grid.jet.sh @@ -65,14 +65,17 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export res=96 export gtype=regional2 # 'uniform', 'stretch', 'nest', or 'regional' -if [ $gtype = stretch ]; then +if [ $gtype = uniform ]; then + export res=96 +elif [ $gtype = stretch ]; then + export res=96 export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile export target_lat=35.5 # Center latitude of the highest resolution tile elif [ $gtype = nest ] || [ $gtype = regional ]; then + export res=96 export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile export target_lat=35.5 # Center latitude of the highest resolution tile @@ -83,6 +86,7 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then export jend_nest=164 # Ending j-direction index of nest grid in parent tile supergrid export halo=3 # Lateral boundary halo elif [ $gtype = regional2 ] ; then + export res=-999 # equivalent resolution is computed export target_lon=-97.5 # Center longitude of grid export target_lat=35.5 # Center latitude of grid export idim=301 # Dimension of grid in 'i' direction @@ -109,7 +113,7 @@ fi export home_dir=$SLURM_SUBMIT_DIR/.. export TMPDIR=/mnt/lfs3/projects/emcda/$LOGNAME/stmp/fv3_grid.$gtype -export out_dir=/mnt/lfs3/projects/emcda/$LOGNAME/stmp/C${res} +export out_dir=/mnt/lfs3/projects/emcda/$LOGNAME/stmp/my_grids #----------------------------------------------------------------------- # Should not need to change anything below here. From c57df01ccfe28ed46946d74ac9114323eb8b3403 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 2 Jun 2020 18:07:45 +0000 Subject: [PATCH 17/38] feature/regional_grid This commit references #4. Update 'global_equiv_resol' and 'regional_grid' codes to build with cmake. --- sorc/fre-nctools.fd/CMakeLists.txt | 2 + .../tools/global_equiv_resol.fd/.gitignore | 2 - .../global_equiv_resol.fd/CMakeLists.txt | 10 +++++ .../tools/global_equiv_resol.fd/Makefile | 24 ----------- .../tools/global_equiv_resol.fd/build.sh | 40 ------------------- .../tools/regional_grid.fd/.gitignore | 3 -- .../tools/regional_grid.fd/CMakeLists.txt | 18 +++++++++ .../tools/regional_grid.fd/Makefile | 22 ---------- .../tools/regional_grid.fd/build.sh | 40 ------------------- 9 files changed, 30 insertions(+), 131 deletions(-) delete mode 100644 sorc/fre-nctools.fd/tools/global_equiv_resol.fd/.gitignore create mode 100644 sorc/fre-nctools.fd/tools/global_equiv_resol.fd/CMakeLists.txt delete mode 100644 sorc/fre-nctools.fd/tools/global_equiv_resol.fd/Makefile delete mode 100755 sorc/fre-nctools.fd/tools/global_equiv_resol.fd/build.sh delete mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/.gitignore create mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/CMakeLists.txt delete mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/Makefile delete mode 100755 sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh diff --git a/sorc/fre-nctools.fd/CMakeLists.txt b/sorc/fre-nctools.fd/CMakeLists.txt index cec8e70db..c91c92b46 100644 --- a/sorc/fre-nctools.fd/CMakeLists.txt +++ b/sorc/fre-nctools.fd/CMakeLists.txt @@ -4,3 +4,5 @@ add_subdirectory(tools/make_solo_mosaic) add_subdirectory(tools/make_hgrid) add_subdirectory(tools/filter_topo) add_subdirectory(tools/shave.fd) +add_subdirectory(tools/global_equiv_resol.fd) +add_subdirectory(tools/regional_grid.fd) diff --git a/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/.gitignore b/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/.gitignore deleted file mode 100644 index 8d61049d4..000000000 --- a/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -global_equiv_resol -global_equiv_resol.o diff --git a/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/CMakeLists.txt b/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/CMakeLists.txt new file mode 100644 index 000000000..549735ac1 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/CMakeLists.txt @@ -0,0 +1,10 @@ +set(fortran_src + global_equiv_resol.f90) + +set(exe_name global_equiv_resol) +add_executable(${exe_name} ${fortran_src}) +target_link_libraries( + ${exe_name} + NetCDF::NetCDF_Fortran) + +install(TARGETS ${exe_name} RUNTIME DESTINATION ${exec_dir}) diff --git a/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/Makefile b/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/Makefile deleted file mode 100644 index d56fd9557..000000000 --- a/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/Makefile +++ /dev/null @@ -1,24 +0,0 @@ -SHELL := bash - -MAKEFLAGS += --warn-undefined-variables - -EXEC = global_equiv_resol - -.PHONY: all -all : $(EXEC) - -$(EXEC): global_equiv_resol.o - $(FC) $(FFLAGS) $(LIBS) -o $@ $^ - -.SUFFIXES: -.SUFFIXES: .f90 .o - -.f90.o: - $(FC) $(FFLAGS) -c $< - -.PHONY: clean -clean: - rm -f *.o *.mod $(EXEC) - -install: - cp $(EXEC) ../../../../exec diff --git a/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/build.sh b/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/build.sh deleted file mode 100755 index f61225136..000000000 --- a/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/build.sh +++ /dev/null @@ -1,40 +0,0 @@ -#!/bin/sh - -set -x - -case $1 in - "cray" ) - export FC=ftn - export FFLAGS="-O2 -g" - export LIBS=" " ;; - "wcoss" ) - export FC=ifort - export FFLAGS="-O2 -g ${NETCDF_FFLAGS}" - export LIBS="${NETCDF_LDFLAGS_F}" ;; - "wcoss_dell_p3" ) - export FC=ifort - export FFLAGS="-O2 -g ${NETCDF_FFLAGS}" - export LIBS="${NETCDF_LDFLAGS_F} ${HDF5_LDFLAGS_F}" ;; - "jet" ) - export FC=ifort - export FFLAGS="-O2 -g -I$NETCDF/include" - export LIBS="-L$NETCDF/lib -lnetcdff -lnetcdf -L${HDF5}/lib -lhdf5 -lhdf5_fortran" ;; - "hera" ) - export FC=ifort - export FFLAGS="-O2 -g -I$NETCDF/include" - export LIBS="-L$NETCDF/lib -lnetcdff -lnetcdf -L${HDF5}/lib -lhdf5 -lhdf5_fortran" ;; - *) - echo "GLOBAL_EQUIV_RESOL UTILITY BUILD NOT TESTED ON MACHINE $1" - exit 1 ;; -esac - -make clean -make -make install - -if ((rc != 0)); then - echo "ERROR BUILDING GLOBAL_EQUIV_RESOL UTILITY" - exit $rc -else - exit 0 -fi diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/.gitignore b/sorc/fre-nctools.fd/tools/regional_grid.fd/.gitignore deleted file mode 100644 index d177f6269..000000000 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -regional_grid -*.mod -*.o diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/CMakeLists.txt b/sorc/fre-nctools.fd/tools/regional_grid.fd/CMakeLists.txt new file mode 100644 index 000000000..fd7f73eab --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/CMakeLists.txt @@ -0,0 +1,18 @@ +set(fortran_src + gen_schmidt.f90 + hgrid_ak.f90 + pietc.f90 + pkind.f90 + pmat4.f90 + pmat5.f90 + pmat.f90 + psym2.f90 + regional_grid.f90) + +set(exe_name regional_grid) +add_executable(${exe_name} ${fortran_src}) +target_link_libraries( + ${exe_name} + NetCDF::NetCDF_Fortran) + +install(TARGETS ${exe_name} RUNTIME DESTINATION ${exec_dir}) diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/Makefile b/sorc/fre-nctools.fd/tools/regional_grid.fd/Makefile deleted file mode 100644 index 799e11b30..000000000 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/Makefile +++ /dev/null @@ -1,22 +0,0 @@ -SHELL := bash - -REGIONAL_GRID=regional_grid - -.PHONY: all -all : $(REGIONAL_GRID) - -$(REGIONAL_GRID): pkind.o pietc.o pmat.o pmat4.o pmat5.o psym2.o gen_schmidt.o hgrid_ak.o regional_grid.o - $(FCMP) $(FFLAGS) ${LIBS} -o $@ $^ - -.SUFFIXES: -.SUFFIXES: .f90 .o - -.f90.o: - $(FCMP) $(FFLAGS) -c $< - -.PHONY: clean -clean: - rm -f *.o *.mod $(REGIONAL_GRID) - -install: - cp $(REGIONAL_GRID) ../../../../exec diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh b/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh deleted file mode 100755 index e9fa48b7d..000000000 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/build.sh +++ /dev/null @@ -1,40 +0,0 @@ -#!/bin/sh - -set -x - -case $1 in - "cray" ) - export FCMP=ftn - export FFLAGS="-O2 -g" - export LIBS=" " ;; - "wcoss" ) - export FCMP=ifort - export FFLAGS="-O2 -g ${NETCDF_FFLAGS}" - export LIBS="${NETCDF_LDFLAGS_F}" ;; - "wcoss_dell_p3" ) - export FCMP=ifort - export FFLAGS="-O2 -g ${NETCDF_FFLAGS}" - export LIBS="${NETCDF_LDFLAGS_F} ${HDF5_LDFLAGS_F}" ;; - "jet" ) - export FCMP=ifort - export FFLAGS="-O2 -g -I$NETCDF/include" - export LIBS="-L$NETCDF/lib -lnetcdff -lnetcdf -L${HDF5}/lib -lhdf5 -lhdf5_fortran" ;; - "hera" ) - export FCMP=ifort - export FFLAGS="-O2 -g -I$NETCDF/include" - export LIBS="-L$NETCDF/lib -lnetcdff -lnetcdf -L${HDF5}/lib -lhdf5 -lhdf5_fortran" ;; - *) - echo "REGIONAL GRID UTILITY BUILD NOT TESTED ON MACHINE $1" - exit 1 ;; -esac - -make clean -make -make install - -if ((rc != 0)); then - echo "ERROR BUILDING REGIONAL GRID UTILITY" - exit $rc -else - exit 0 -fi From f90f02542ac604a79ec910b928018c566fd9fc84 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 2 Jun 2020 18:34:50 +0000 Subject: [PATCH 18/38] feature/regional_grid This commit references #4. Update ush/fv3gfs_driver_grid.sh for new name of 'shave' executable. --- ush/fv3gfs_driver_grid.sh | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh index fc081f4eb..2295bddf5 100755 --- a/ush/fv3gfs_driver_grid.sh +++ b/ush/fv3gfs_driver_grid.sh @@ -497,8 +497,8 @@ elif [ $gtype = regional2 ]; then echo $idim $jdim $halop1 \'$filter_dir/oro.C${res}.tile${tile}.nc\' \'$filter_dir/oro.C${res}.tile${tile}.shave.nc\' >input.shave.orog echo $idim $jdim $halop1 \'$filter_dir/C${res}_grid.tile${tile}.nc\' \'$filter_dir/C${res}_grid.tile${tile}.shave.nc\' >input.shave.grid - $APRUN $exec_dir/shave.x input.shave.orog.halo$halo echo $idim $jdim $halo \'$filter_dir/C${res}_grid.tile${tile}.nc\' \'$filter_dir/C${res}_grid.tile${tile}.shave.nc\' >input.shave.grid.halo$halo - $APRUN $exec_dir/shave.x input.shave.orog.halo0 echo $idim $jdim 0 \'$filter_dir/C${res}_grid.tile${tile}.nc\' \'$filter_dir/C${res}_grid.tile${tile}.shave.nc\' >input.shave.grid.halo0 - $APRUN $exec_dir/shave.x Date: Wed, 3 Jun 2020 12:25:10 +0000 Subject: [PATCH 19/38] feature/regional_grid This commit references #4. Update archive directory for Jet. --- driver_scripts/driver_grid.jet.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/driver_scripts/driver_grid.jet.sh b/driver_scripts/driver_grid.jet.sh index ed99d66a0..3ee9bd8b1 100755 --- a/driver_scripts/driver_grid.jet.sh +++ b/driver_scripts/driver_grid.jet.sh @@ -108,7 +108,7 @@ fi export home_dir=$SLURM_SUBMIT_DIR/.. export TMPDIR=/lfs4/HFIP/emcda/$LOGNAME/stmp/fv3_grid.$gtype -export out_dir=/lfs4/HFIP/emcda/$LOGNAME/stmp/C${res} +export out_dir=/lfs4/HFIP/emcda/$LOGNAME/stmp/my_grids #----------------------------------------------------------------------- # Should not need to change anything below here. From c9ef8bd202f73c85316c8d2f4749a1616e1be086 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 17 Jun 2020 12:38:59 +0000 Subject: [PATCH 20/38] feature/regional_grid This commit references NOAA-EMC#4. Update Jim's regional code to the latest version from Dusan's regional workflow branch. This update adds new records 'dx', 'dy', 'angle_dx', and 'angle_dy' to the grid files. --- .../tools/regional_grid.fd/hgrid_ak.f90 | 180 ++++++++++++++---- .../tools/regional_grid.fd/regional_grid.f90 | 37 +++- 2 files changed, 176 insertions(+), 41 deletions(-) diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 index 389f53a69..4848c4be6 100644 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 @@ -1,6 +1,6 @@ !============================================================================= subroutine hgrid_ak(lx,ly,nx,ny,a,k,plat,plon,pazi, & - re,delx,dely, glat,glon,garea, ff) + re,delx,dely, glat,glon,garea,dx,dy,angle_dx,angle_dy, ff) !============================================================================= ! Use a and k as the parameters of a generalized Schmidt-transformed ! gnomonic mapping centered at (plat,plon) and twisted about this center @@ -17,15 +17,21 @@ subroutine hgrid_ak(lx,ly,nx,ny,a,k,plat,plon,pazi, & ! 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 ! in the SQUARE of the same physical length unit that was employed to define -! the radius of the earth, re (and the central grid steps, delx and dely). +! the radius of the earth, re, and the central grid steps, delx and dely. +! 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 snd 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 degrees 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 pkind, only: dp -use pietc, only: u0,u1,dtor -use pmat4, only: sarea +use pietc, only: u0,u1,dtor,rtod +use pmat4, only: cross_product,triple_product use pmat5, only: ctog implicit none integer, intent(in ):: lx,ly,nx,ny @@ -33,17 +39,27 @@ subroutine hgrid_ak(lx,ly,nx,ny,a,k,plat,plon,pazi, & re,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 -real(dp),dimension(3) :: xc +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,& rlat,drlata,drlatb,drlatc, & - rlon,drlona,drlonb,drlonc, rre -integer :: ix,iy,mx,my + rlon,drlona,drlonb,drlonc, delxy,delxore,delyore +integer :: ix,iy,mx,my,lxm,lym,mxp,myp !============================================================================= +delxore=delx/re +delyore=dely/re +delxy=delx*dely clat=cos(plat); slat=sin(plat) clon=cos(plon); slon=sin(plon) cazi=cos(pazi); sazi=sin(pazi) @@ -56,49 +72,135 @@ subroutine hgrid_ak(lx,ly,nx,ny,a,k,plat,plon,pazi, & 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 -!This code assumes symmetry about the grid center +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/re - xm(2)=-iy*dely/re + xm(2)=iy*delyore do ix=lx,mx - !xm(1)=ix*delx/re - xm(1)=-ix*delx/re - call xmtoxc_ak(a,k,xm,xc,xcd,ff) - if(ff)return + xm(1)=ix*delxore + call xmtoxc_ak(a,k,xm,xc,xcd,ff); if(ff)return xcd=matmul(prot,xcd) xc =matmul(prot,xc ) call ctog(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))*rtod + angle_dy(ix,iy)=atan2(-xcd2(1,2),xcd2(2,2))*rtod + 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*delxore +do iy=ly,my + xm(2)=iy*delyore + 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*delxore +do iy=ly,my + xm(2)=iy*delyore + 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*delyore +do ix=lx,mx + xm(1)=ix*delxore + 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*delyore +do ix=lx,mx + xm(1)=ix*delxore + 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*delyore +!-- extra bottom left corner: +xm(1)=lxm*delxore +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*delxore +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*delyore +!-- extra top left corner: +xm(1)=lxm*delxore +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*delxore +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*(dxt(lx :mx-1,:)+dxt(lx+1:mx ,:)) & + -(dxt(lxm:mx-2,:)+dxt(lx+2:mxp,:)))/24 +dy =(13*(dyt(:,ly :my-1)+dyt(:,ly+1:my )) & + -(dyt(:,lym:my-2)+dyt(:,ly+2:myp)))/24 +gat(lx:mx-1,:)=(13*(gat(lx :mx-1,:)+gat(lx+1:mx ,:)) & + -(gat(lxm:mx-2,:)+gat(lx+2:mxp,:)))/24 +garea =(13*(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 ! Convert degrees to radians in the glat and glon arrays: glat=glat*dtor glon=glon*dtor -! 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 -! Convert the areas to area units consistent with the length units used for -! the radius, re, of the sphere: -rre=re*re -garea=garea*rre - end subroutine hgrid_ak diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/regional_grid.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/regional_grid.f90 index 96cab654f..4d55bfc59 100644 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/regional_grid.f90 +++ b/sorc/fre-nctools.fd/tools/regional_grid.fd/regional_grid.f90 @@ -23,6 +23,7 @@ program regional_grid real(dp),dimension(:,:),allocatable:: glat,glon real(dp),dimension(:,:),allocatable:: garea + real(dp),dimension(:,:),allocatable:: dx,dy,angle_dx,angle_dy character(len=256) :: nml_fname @@ -30,6 +31,7 @@ program regional_grid integer :: ncid integer :: string_dimid, nxp_dimid, nyp_dimid, nx_dimid, ny_dimid integer :: tile_varid, x_varid, y_varid, area_varid + integer :: dx_varid, dy_varid, angle_dx_varid, angle_dy_varid integer, dimension(2) :: dimids !============================================================================= @@ -56,9 +58,14 @@ program regional_grid allocate(glon(0:nx,0:ny)) allocate(garea(0:nxm,0:nym)) + allocate(dx(0:nxm,0:ny)) + allocate(dy(0:nx,0:nym)) + allocate(angle_dx(0:nx,0:ny)) + allocate(angle_dy(0:nx,0:ny)) + call hgrid_ak(lx,ly,nx,ny,a,k,plat*dtor,plon*dtor,pazi*dtor, & - re,redelx,redely, glat,glon,garea, ff) - if(ff)stop 'Failure flag raised in hgrid routine' + re,redelx,redely, glat,glon,garea,dx,dy,angle_dx,angle_dy, ff) + if(ff)stop 'Failure flag raised in hgrid_ak routine' glon = glon*rtod glat = glat*rtod @@ -89,6 +96,28 @@ program regional_grid call check( nf90_put_att(ncid, area_varid, "units", "m2") ) call check( nf90_put_att(ncid, area_varid, "hstagger", "H") ) + dimids = (/ nx_dimid, nyp_dimid /) + call check( nf90_def_var(ncid, "dx", NF90_DOUBLE, dimids, dx_varid) ) + call check( nf90_put_att(ncid, dx_varid, "standard_name", "dx") ) + call check( nf90_put_att(ncid, dx_varid, "units", "m") ) + call check( nf90_put_att(ncid, dx_varid, "hstagger", "H") ) + + dimids = (/ nxp_dimid, ny_dimid /) + call check( nf90_def_var(ncid, "dy", NF90_DOUBLE, dimids, dy_varid) ) + call check( nf90_put_att(ncid, dy_varid, "standard_name", "dy") ) + call check( nf90_put_att(ncid, dy_varid, "units", "m") ) + call check( nf90_put_att(ncid, dy_varid, "hstagger", "H") ) + + dimids = (/ nxp_dimid, nyp_dimid /) + call check( nf90_def_var(ncid, "angle_dx", NF90_DOUBLE, dimids, angle_dx_varid) ) + call check( nf90_put_att(ncid, angle_dx_varid, "standard_name", "angle_dx") ) + call check( nf90_put_att(ncid, angle_dx_varid, "units", "deg") ) + call check( nf90_put_att(ncid, angle_dx_varid, "hstagger", "C") ) + call check( nf90_def_var(ncid, "angle_dy", NF90_DOUBLE, dimids, angle_dy_varid) ) + call check( nf90_put_att(ncid, angle_dy_varid, "standard_name", "angle_dy") ) + call check( nf90_put_att(ncid, angle_dy_varid, "units", "deg") ) + call check( nf90_put_att(ncid, angle_dy_varid, "hstagger", "C") ) + call check( nf90_put_att(ncid, NF90_GLOBAL, "history", "gnomonic_ed") ) call check( nf90_put_att(ncid, NF90_GLOBAL, "source", "FV3GFS") ) call check( nf90_put_att(ncid, NF90_GLOBAL, "grid", "akappa") ) @@ -108,6 +137,10 @@ program regional_grid call check( nf90_put_var(ncid, x_varid, glon) ) call check( nf90_put_var(ncid, y_varid, glat) ) call check( nf90_put_var(ncid, area_varid, garea) ) + call check( nf90_put_var(ncid, dx_varid, dx) ) + call check( nf90_put_var(ncid, dy_varid, dy) ) + call check( nf90_put_var(ncid, angle_dx_varid, angle_dx) ) + call check( nf90_put_var(ncid, angle_dy_varid, angle_dy) ) call check( nf90_close(ncid) ) From 33451ee73b59599d3935f2d4a6f32dd46e7d25e1 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 17 Jun 2020 13:27:26 +0000 Subject: [PATCH 21/38] feature/regional_grid This commit references NOAA-EMC#4. Add new regional_esg_grid code, which is a possible replacement for the original regional_grid code. Taken from Dusan's regional workflow branch. --- sorc/fre-nctools.fd/CMakeLists.txt | 1 + .../tools/regional_esg_grid.fd/CMakeLists.txt | 20 + .../tools/regional_esg_grid.fd/pesg.f90 | 1384 +++++++++++ .../tools/regional_esg_grid.fd/pfun.f90 | 218 ++ .../tools/regional_esg_grid.fd/pietc.f90 | 96 + .../tools/regional_esg_grid.fd/pietc_s.f90 | 95 + .../tools/regional_esg_grid.fd/pkind.f90 | 13 + .../tools/regional_esg_grid.fd/pmat.f90 | 1097 +++++++++ .../tools/regional_esg_grid.fd/pmat2.f90 | 1267 ++++++++++ .../tools/regional_esg_grid.fd/pmat4.f90 | 2060 +++++++++++++++++ .../tools/regional_esg_grid.fd/pmat5.f90 | 987 ++++++++ .../tools/regional_esg_grid.fd/psym2.f90 | 537 +++++ .../regional_esg_grid.f90 | 182 ++ 13 files changed, 7957 insertions(+) create mode 100644 sorc/fre-nctools.fd/tools/regional_esg_grid.fd/CMakeLists.txt create mode 100644 sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pesg.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pfun.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pietc.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pietc_s.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pkind.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat2.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat4.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat5.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_esg_grid.fd/psym2.f90 create mode 100644 sorc/fre-nctools.fd/tools/regional_esg_grid.fd/regional_esg_grid.f90 diff --git a/sorc/fre-nctools.fd/CMakeLists.txt b/sorc/fre-nctools.fd/CMakeLists.txt index c91c92b46..6a0c51673 100644 --- a/sorc/fre-nctools.fd/CMakeLists.txt +++ b/sorc/fre-nctools.fd/CMakeLists.txt @@ -6,3 +6,4 @@ add_subdirectory(tools/filter_topo) add_subdirectory(tools/shave.fd) add_subdirectory(tools/global_equiv_resol.fd) add_subdirectory(tools/regional_grid.fd) +add_subdirectory(tools/regional_esg_grid.fd) diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/CMakeLists.txt b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/CMakeLists.txt new file mode 100644 index 000000000..2e3e93295 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/CMakeLists.txt @@ -0,0 +1,20 @@ +set(fortran_src + pesg.f90 + pfun.f90 + pietc.f90 + pietc_s.f90 + pkind.f90 + pmat.f90 + pmat2.f90 + pmat4.f90 + pmat5.f90 + psym2.f90 + regional_esg_grid.f90) + +set(exe_name regional_esg_grid) +add_executable(${exe_name} ${fortran_src}) +target_link_libraries( + ${exe_name} + NetCDF::NetCDF_Fortran) + +install(TARGETS ${exe_name} RUNTIME DESTINATION ${exec_dir}) diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pesg.f90 b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pesg.f90 new file mode 100644 index 000000000..5dc96b5ec --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pesg.f90 @@ -0,0 +1,1384 @@ +! +! *********************** +! * pesg.f90 * +! * R. J. Purser * +! * NOAA/NCEP/EMC * +! * May 2020 * +! * * +! * jim.purser@noaa.gov * +! *********************** +! 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 +implicit none +private +public :: xctoxs,xstoxc,xstoxt,xttoxs,xttoxm,zttozm,zmtozt,xctoxm_ak,xmtoxc_ak,& + getedges,get_qq,get_qofmap,get_bestesg,get_bestesg_inv, & + hgrid_ak_rr,hgrid_ak_rc,hgrid_ak_dd,hgrid_ak_dc,hgrid_ak +interface xctoxs; module procedure xctoxs; end interface +interface xstoxc; module procedure xstoxc; end interface +interface xstoxt; module procedure xstoxt; end interface +interface xttoxs; module procedure xttoxs; end interface +interface xttoxm; module procedure xttoxm; end interface +interface zttozm; module procedure zttozm; end interface +interface zmtozt; module procedure zmtozt; end interface +interface xctoxm_ak; module procedure xctoxm_ak; end interface +interface xmtoxc_ak; module procedure xmtoxc_ak; end interface +interface getedges; module procedure getedges; end interface +interface get_wxy; module procedure get_wxy; end interface +interface get_qq; module procedure get_qqw,get_qqt; end interface +interface get_qofmap; module procedure get_qofmap; end interface +interface get_bestesg; module procedure get_bestesg; end interface +interface get_bestesgt; module procedure get_bestesgt; end interface +interface get_bestesg_inv;module procedure get_bestesg_inv; 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 +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 xstoxt(kappa,xs,xt,ff)! [xstoxt] +!============================================================================= +! Inverse of xttoxs. +!============================================================================= +implicit none +real(dp), intent(in ):: kappa +real(dp),dimension(2),intent(in ):: xs +real(dp),dimension(2),intent(out):: xt +logical, intent(out):: ff +!----------------------------------------------------------------------------- +real(dp):: s,sc +!============================================================================= +s=kappa*(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(kappa,xt,xs,xsd,ff)! [xttoxs] +!============================================================================== +! Scaled gnomonic plane xt to standard stereographic plane xs +!============================================================================== +implicit none +real(dp), intent(in ):: kappa +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):: s,sp,rsp,rspp,rspps,rspdx,rspdy +!============================================================================== +s=kappa*(xt(1)*xt(1) + xt(2)*xt(2)); sp=u1+s +ff=(sp<=u0); if(ff)return +rsp=sqrt(sp) +rspp=u1+rsp +rspps=rspp**2 +xs=xt/rspp +rspdx=kappa*xt(1)/rsp +rspdy=kappa*xt(2)/rsp +xsd(1,1)=u1/rspp -xt(1)*rspdx/rspps +xsd(1,2)= -xt(1)*rspdy/rspps +xsd(2,1)= -xt(2)*rspdx/rspps +xsd(2,2)=u1/rspp -xt(2)*rspdy/rspps +end subroutine xttoxs + +!============================================================================= +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 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(a4)stop 'In get_wxy; ncor is out of bounds' +if(ncor>=min(nxh,nyh))stop 'In get_wxy; ncor is too large for this small grid' +! the wx and wy are the weight coefficients for an unnormalized +! extended trapezoidal integration. The end correction coefficients can +! be found by staggering, then summing, the Adams-Moulton coefficients +! at both ends. +wx=u1; wx(0)=o2; wx(nxh:nxh-ncor:-1)=cor +wy=u1; wy(0)=o2; wy(nyh:nyh-ncor:-1)=cor +wxy=outer_product(wx,wy); wxy=wxy/sum(wxy) +end subroutine get_wxy + +!============================================================================= +subroutine get_qqw(nxh,nyh,ncor,j0xy,tw,p,q)! [get_qq] +!============================================================================= +! Like get_qqt, except the square norm involved in the definition of Q is +! modified by including a "trace-weight" proportion, tw, of the squared-trace. +! (Elsewhere tw is also known as "lambda".) +! In the elasticity analogue, this extra degree of freedom is like being +! able to include a nontrivial Poisson ratio defining the elastic modulus. +!============================================================================= +use pmat4, only: outer_product +use psym2, only: logsym2,expsym2 +implicit none +integer(spi), intent(in ):: nxh,nyh,ncor +real(dp),dimension(3,2,0:nxh,0:nyh),intent(in ):: j0xy +real(dp), intent(in ):: tw +real(dp),dimension(2,2), intent(inout):: p +real(dp), intent( out):: q +!----------------------------------------------------------------------------- +integer(spi),parameter :: nit=5 +real(dp),parameter :: acrit=1.e-8_dp,dpx=.0099e0_dp +real(dp),dimension(0:nxh,0:nyh):: wxy +real(dp),dimension(3,2) :: j0,j +real(dp),dimension(2,2) :: el,pf,elp,elmean,g,ppx,pmx,ppy,pmy +real(dp),dimension(2) :: hess,grad +real(dp) :: anorm,q00,qpx,qmx,qpy,qmy,c,w,twc +integer(spi) :: ix,iy,it +!============================================================================= +call get_wxy(nxh,nyh,ncor,wxy)! <- get 2D extended trapezoidal averaging wts +twc=u1-tw +if(p(1,1)==u0)then; p=u0; p(1,1)=u1; p(2,2)=u1; endif +! Iteratively calibrate preconditioner, p, to make elmean vanish: +anorm=u1 +do it=1,nit + elmean=u0 + q=u0 + do iy=0,nyh; do ix=0,nxh + j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) +! Precondition the Jacobian using latest iteration of P: + j=matmul(j0,p) +! Find the Gram matrix, G, implied by the column vectors of the new J: + g=matmul(transpose(j),j) +! Find the matrix logarithm, L = 0.5*log(G), contributions to elmean and q: + call logsym2(g,el); el=el*o2; elmean=elmean+w*el + q=q+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) + enddo; ; enddo + if(anormnit)& +print'("WARNING: In get_qqw, relatively inferior convergence; anorm=",1x,e12.5)',anorm +q00=q +ppx=p; ppx(1,1)=ppx(1,1)*(u1+dpx);qpx=u0 +pmx=p; pmx(1,1)=pmx(1,1)*(u1-dpx);qmx=u0 +ppy=p; ppy(2,2)=ppy(2,2)*(u1+dpx);qpy=u0 +pmy=p; pmy(2,2)=pmy(2,2)*(u1-dpx);qmy=u0 +do iy=0,nyh; do ix=0,nxh + j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) + j=matmul(j0,ppx); g=matmul(transpose(j),j) + call logsym2(g,el);el=el*o2;qpx=qpx+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) + j=matmul(j0,pmx); g=matmul(transpose(j),j) + call logsym2(g,el);el=el*o2;qmx=qmx+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) + j=matmul(j0,ppy); g=matmul(transpose(j),j) + call logsym2(g,el);el=el*o2;qpy=qpy+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) + j=matmul(j0,pmy); g=matmul(transpose(j),j) + call logsym2(g,el);el=el*o2;qmy=qmy+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) +enddo; enddo +! Estimate a (diagonal) Hessian matrix and a gradient vector: +hess=(/ (qpx-u2*q00+qmx)/dpx**2, (qpy-u2*q00+qmy)/dpx**2 /) +hess=(/8._dp,8._dp/) +grad=(/ (qpx-qmx)/(u2*dpx) , (qpy-qmy)/(u2*dpx) /) +! If the hessian is positive, polish p with a final Newton iteration: +if(hess(1)>u0 .and. hess(2)>u0)then + c=u1-grad(1)/hess(1); p(:,1)=p(:,1)*c + c=u1-grad(2)/hess(2); p(:,2)=p(:,2)*c +endif + +! and calculate the new q. Keep it only if it's numerically smaller than before: +q00=0 +do iy=0,nyh; do ix=0,nxh + j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) + j=matmul(j0,p); g=matmul(transpose(j),j) + call logsym2(g,el);el=el*o2;q00=q00+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) +enddo; enddo +if(q00nit)print'(" WARNING: In get_qqt, relatively inferior convergence")' + +q00=q +ppx=p; ppx(1,1)=ppx(1,1)*(1+dpx);qpx=0 +pmx=p; pmx(1,1)=pmx(1,1)*(1-dpx);qmx=0 +ppy=p; ppy(2,2)=ppy(2,2)*(1+dpx);qpy=0 +pmy=p; pmy(2,2)=pmy(2,2)*(1-dpx);qmy=0 +do iy=0,nyh; do ix=0,nxh + j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) + j=matmul(j0,ppx); g=matmul(transpose(j),j) + call logsym2(g,el); el=el/2; qpx=qpx+w*sum(el**2) + j=matmul(j0,pmx); g=matmul(transpose(j),j) + call logsym2(g,el); el=el/2; qmx=qmx+w*sum(el**2) + j=matmul(j0,ppy); g=matmul(transpose(j),j) + call logsym2(g,el); el=el/2; qpy=qpy+w*sum(el**2) + j=matmul(j0,pmy); g=matmul(transpose(j),j) + call logsym2(g,el); el=el/2; qmy=qmy+w*sum(el**2) +enddo; enddo +! Estimate a (diagonal) Hessian matrix and a gradient vector: +hess=(/ (qpx-2*q00+qmx)/dpx**2, (qpy-2*q00+qmy)/dpx**2 /) +grad=(/ (qpx-qmx)/(2*dpx) , (qpy-qmy)/(2*dpx) /) + +! If the hessian is positive, polish the final p with a final Newton iteration: +if(hess(1)>0 .and. hess(2)>0.)then + c=u1-grad(1)/hess(1); p(:,1)=p(:,1)*c + c=u1-grad(2)/hess(2); p(:,2)=p(:,2)*c +endif + +! and calculate the new q. Keep it only if is numerically smaller than before: +q00=0 +do iy=0,nyh; do ix=0,nxh + j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) + j=matmul(j0,p); g=matmul(transpose(j),j) + call logsym2(g,el); el=el*o2; q00=q00+w*sum(el**2) +enddo; enddo +if(q00=u1 +if(ff)then + print'("In get_bestesg; invalid optimization criterion parameter, lam")' + return +endif +ff= arcx<=u0 .or. arcy<=u0 +if(ff)then + print'("In get_bestesg; a nonpositive domain parameter, arcx or arcy")' + return +endif +! Make tarcx the longer of the two semi-axes of the domain: +flip=arcy>arcx +if(flip)then; tarcx=arcy; tarcy=arcx ! <- switch +else ; tarcx=arcx; tarcy=arcy ! <- don't switch +endif +asp=tarcy/tarcx ! <- Domain aspect ratio that does not exceed one +sarcx=tarcx/darc +i0=floor(sarcx); i1=i0+1; wi0=i1-sarcx; wi1=sarcx-i0 +ff=i1>marc +if(ff)then + print'("In get_bestesg; domain length too large")'; return +endif +asplim=u1 ! <- Default aspect ratio limit for small tarcx +if(i0>=larc)then ! Interpolate aspect limit for this large tarcx from the table: + slam=lam/dlam + j0=floor(slam) ; j1=j0+1; wj0=j1-slam; wj1=slam -j0 + asplim=(asplims(j0,i0)*wi0+asplims(j0,i1)*wi1)*wj0 + & + (asplims(j1,i0)*wi0+asplims(j1,i1)*wi1)*wj1 +endif +ff=asp>asplim +if(ff)then + print'("In get_bestesg; domain width too large for given domain length")' + return +endif +call get_bestesgt(lam,asp,tarcx, A,K,tm_arcx,tm_arcy,q,ff) +if(ff)return +if(flip)then; m_arcx=tm_arcy; m_arcy=tm_arcx +else ; m_arcx=tm_arcx; m_arcy=tm_arcy +endif +end subroutine get_bestesg + +!============================================================================= +subroutine get_bestesgt(lam,asp,arcx, a,k,m_arcx,m_arcy,q,ff)! [get_betsesgt] +!============================================================================= +! With prescribed optimization criterion parameter, lam ("lambda"), +! aspect ratio, asp (0.1 < asp <= 1.), major semi-arc, in degrees, of arcx, +! return the best Extended Schmidt-Gnomonic (ESG) mapping parameters, A and K, +! for the rectangular domain whose edge midpoints are distant arcx and asp*arcx +! from its center. +! Also, return the map-space x and y coordinates, m_arcx, m_arcy, of +! the domain edges in the positive directions. +! The optimality criterion, Q(A,K), which this routine aims to minimize, +! is provided upon return. However A and K are independenly scaled, the contours +! Q are highly elliptical; the differencing stencil is adjusted to mimic this +! stretching to preserve good numerical conditioning of the calculations and, we +! hope, tl thereby ensure an accurate and robust estimation of the location of +! the minimum. +! If the process fails for any reason (such as parameter combinations, lam, asp, +! arcx for which no minimum of Q in the proper interior of the valid space +! of these parameters exists), then the failure flag, FF, is raised (.true.) +! and the output parameters are then of course meaningless. +!============================================================================= +use pietc, only: u5,o5,s18,s36,s54,s72,ms18,ms36,ms54,ms72,pi2 +use psym2, only: chol2 +implicit none +real(dp),intent(in ):: lam,arcx,asp +real(dp),intent(out):: a,k,m_arcx,m_arcy,q +logical, intent(out):: ff +!----------------------------------------------------------------------------- +integer(spi),parameter :: narc=11,nasp=10,nit=8,nang=5 +real(dp),parameter :: eps=1.e-7_dp,u2o5=u2*o5,darc=10._dp+eps,& + dasp=.1_dp+eps,dang=pi2*o5,r=0.0001_dp,rr=r*r, & + urc=.4_dp, & ! <- Under-relaxation coefficient + enxyq=10000._dp! ~ pts in trial grid quadrant +real(dp),parameter :: f18=u2o5*s18,f36=u2o5*s36,f54=u2o5*s54,f72=u2o5*s72,& + mf18=-f18,mf36=-f36,mf54=-f54,mf72=-f72 !<- (Fourier) +real(dp),dimension(0:4,0:4) :: em5 ! <- Fourier matrix for 5 points +real(dp),dimension(nasp,0:narc):: adarc,kdarc ! < 1st guess tables of A and K. +real(dp),dimension(0:nang-1) :: qs +real(dp),dimension(2,0:nang-1) :: aks +real(dp),dimension(2) :: grad,v2,ak +real(dp),dimension(2,2) :: hess,el,basis0,basis +real(dp),dimension(3) :: xcedgex,xcedgey +real(dp),dimension(2) :: xmedgex,xmedgey +real(dp) :: ang,sarcx,sasp,wx0,wx1,wa0,wa1,qold +integer(spi) :: i,it,iarcx0,iasp0,iarcx1,iasp1,& + nxh,nyh +!------------------------ +! Tables of approximate A (adarc) and K (kdarc), valid for lam=0.8, for aspect ratio, +! asp, at .1, .2, .3, .4, .5, .6, .7, .8, 1. and major semi-arc, arcx, at values, +! 0 (nominally), 10., ..., 100. degrees (where the nominal "0" angle is actually +! from a computation at 3 degrees, since zero would not make sense). +! The 100 degree rows are repeated as the 110 degree entries deliberately to pad the +! table into the partly forbidden parameter space to allow skinny domains of up to +! 110 degree semi-length to be validly endowed with optimal A and K: +data adarc/ & +-.450_dp,-.328_dp,-.185_dp,-.059_dp,0.038_dp,0.107_dp,0.153_dp,0.180_dp,0.195_dp,0.199_dp,& +-.452_dp,-.327_dp,-.184_dp,-.058_dp,0.039_dp,0.108_dp,0.154_dp,0.182_dp,0.196_dp,0.200_dp,& +-.457_dp,-.327_dp,-.180_dp,-.054_dp,0.043_dp,0.112_dp,0.158_dp,0.186_dp,0.200_dp,0.205_dp,& +-.464_dp,-.323_dp,-.173_dp,-.047_dp,0.050_dp,0.118_dp,0.164_dp,0.192_dp,0.208_dp,0.213_dp,& +-.465_dp,-.313_dp,-.160_dp,-.035_dp,0.060_dp,0.127_dp,0.173_dp,0.202_dp,0.217_dp,0.224_dp,& +-.448_dp,-.288_dp,-.138_dp,-.017_dp,0.074_dp,0.140_dp,0.184_dp,0.213_dp,0.230_dp,0.237_dp,& +-.395_dp,-.244_dp,-.104_dp,0.008_dp,0.093_dp,0.156_dp,0.199_dp,0.227_dp,0.244_dp,0.252_dp,& +-.301_dp,-.177_dp,-.057_dp,0.042_dp,0.119_dp,0.175_dp,0.215_dp,0.242_dp,0.259_dp,0.269_dp,& +-.185_dp,-.094_dp,0.001_dp,0.084_dp,0.150_dp,0.199_dp,0.235_dp,0.260_dp,0.277_dp,0.287_dp,& +-.069_dp,-.006_dp,0.066_dp,0.132_dp,0.186_dp,0.227_dp,0.257_dp,0.280_dp,0.296_dp,0.308_dp,& +0.038_dp,0.081_dp,0.134_dp,0.185_dp,0.226_dp,0.258_dp,0.283_dp,0.303_dp,0.319_dp,0.333_dp,& +0.038_dp,0.081_dp,0.134_dp,0.185_dp,0.226_dp,0.258_dp,0.283_dp,0.303_dp,0.319_dp,0.333_dp/ + +data kdarc/ & +-.947_dp,-.818_dp,-.668_dp,-.535_dp,-.433_dp,-.361_dp,-.313_dp,-.284_dp,-.269_dp,-.264_dp,& +-.946_dp,-.816_dp,-.665_dp,-.533_dp,-.431_dp,-.359_dp,-.311_dp,-.282_dp,-.267_dp,-.262_dp,& +-.942_dp,-.806_dp,-.655_dp,-.524_dp,-.424_dp,-.353_dp,-.305_dp,-.276_dp,-.261_dp,-.255_dp,& +-.932_dp,-.789_dp,-.637_dp,-.509_dp,-.412_dp,-.343_dp,-.296_dp,-.266_dp,-.250_dp,-.244_dp,& +-.909_dp,-.759_dp,-.609_dp,-.486_dp,-.394_dp,-.328_dp,-.283_dp,-.254_dp,-.237_dp,-.230_dp,& +-.863_dp,-.711_dp,-.569_dp,-.456_dp,-.372_dp,-.310_dp,-.266_dp,-.238_dp,-.220_dp,-.212_dp,& +-.779_dp,-.642_dp,-.518_dp,-.419_dp,-.343_dp,-.287_dp,-.247_dp,-.220_dp,-.202_dp,-.192_dp,& +-.661_dp,-.556_dp,-.456_dp,-.374_dp,-.310_dp,-.262_dp,-.226_dp,-.200_dp,-.182_dp,-.171_dp,& +-.533_dp,-.462_dp,-.388_dp,-.325_dp,-.274_dp,-.234_dp,-.203_dp,-.179_dp,-.161_dp,-.150_dp,& +-.418_dp,-.373_dp,-.322_dp,-.275_dp,-.236_dp,-.204_dp,-.178_dp,-.156_dp,-.139_dp,-.127_dp,& +-.324_dp,-.296_dp,-.261_dp,-.229_dp,-.200_dp,-.174_dp,-.152_dp,-.133_dp,-.117_dp,-.104_dp,& +-.324_dp,-.296_dp,-.261_dp,-.229_dp,-.200_dp,-.174_dp,-.152_dp,-.133_dp,-.117_dp,-.104_dp/ + +data em5/o5, u2o5, u0, u2o5, u0, & ! <- The Fourier matrix for 5 points. Applied to + o5, f18, f72, mf54, f36, & ! the five 72-degree spaced values in a column- + o5, mf54, f36, f18, mf72, & ! vector, the product vector has the components, + o5, mf54, mf36, f18, f72, & ! wave-0, cos and sin wave-1, cos and sin wave-2. + o5, f18, mf72, mf54, mf36/ + +data basis0/0.1_dp,u0, 0.3_dp,0.3_dp/! <- initial basis for orienting (a,k) differencing +!============================================================================ +sasp=asp/dasp +iasp0=floor(sasp); wa1=sasp-iasp0 +iasp1=iasp0+1; wa0=iasp1-sasp +sarcx=arcx/darc +iarcx0=floor(sarcx); wx1=sarcx-iarcx0 +iarcx1=iarcx0+1; wx0=iarcx1-sarcx +if(iasp0 <1 .or. iasp1 >nasp)stop 'Aspect ratio out of range' +if(iarcx0<0 .or. iarcx1>narc)stop 'Major semi-arc is out of range' +nxh=nint(sqrt(enxyq/asp))! < These nxh and nyh ensure nearly +nyh=nint(sqrt(enxyq*asp))! square trial grid cells, and about enxyq points in total. +call getedges(arcx,asp*arcx, xcedgex,xcedgey) + +! Bilinearly interpolate A and K from crude table into a 2-vector: +ak=(/wx0*(wa0*adarc(iasp0,iarcx0)+wa1*adarc(iasp1,iarcx0))+ & + wx1*(wa0*adarc(iasp0,iarcx1)+wa1*adarc(iasp1,iarcx1)), & + wx0*(wa0*kdarc(iasp0,iarcx0)+wa1*kdarc(iasp1,iarcx0))+ & + wx1*(wa0*kdarc(iasp0,iarcx1)+wa1*kdarc(iasp1,iarcx1))/) +basis=basis0 ! <- initial the basis to a representative guess. +qold=100._dp ! <- initialize qold to a meaningless large value to force at least one + ! complete Newton iteration to occur. +do it=1,nit + call get_qofmap(nxh,nyh,ak(1),ak(2),lam,xcedgex,xcedgey,& + q,xmedgex,xmedgey,ff) + if(ff)return + if(q>=qold)exit ! <-Assume this condition indicates early convergence + m_arcx=xmedgex(1) + m_arcy=xmedgey(2) + qold=q + +! Place five additional sample points around the stencil-ellipse: + do i=0,4 + ang=i*dang ! steps of 72 degrees + v2=(/cos(ang),sin(ang)/)*r ! points on a circle of radius r ... + aks(:,i)=ak+matmul(basis,v2) ! ... become points on an ellipse. +! Get quality, qs(i) + call get_qofmap(nxh,nyh,aks(1,i),aks(2,i),lam,xcedgex,xcedgey,& + qs(i),xmedgex,xmedgey,ff) + enddo + if(ff)return +! Recover gradient and hessian estimates, normalized by q, from all +! 6 samples, q, qs. These are wrt the basis, not (a,k) directly. +! Make qs the 5-pt discrete Fourier coefficients of the ellipse pts: + qs=matmul(em5,qs)/q + grad=qs(1:2)/r ! <- r is the finite differencing step size parameter + qs(0)=qs(0)-u1 ! <- cos(2*ang) coefficient relative to the central value. + hess(1,1)=qs(0)+qs(3)! <- combine cos(0*ang) and cos(2*ang) coefficients + hess(1,2)=qs(4) ! <- sin(2*ang) coefficient + hess(2,1)=qs(4) ! + hess(2,2)=qs(0)-qs(3)! <- combine cos(0*ang) and cos(2*ang) coefficients + hess=hess*u2/rr ! <- rr is r**2 + +! Perform a Cholesky decomposition of the hessian: + call chol2(hess,el,ff) + if(ff)then + print'(" In get_bestESG, hessian is not positive; cholesky fails")' + return + endif +! Invert the cholesky factor in place: + el(1,1)=u1/el(1,1) + el(2,2)=u1/el(2,2) + el(2,1)=-el(2,1)*el(1,1)*el(2,2) +! Estimate a Newton step towards the minimum of function Q(a,k): + v2=-matmul(transpose(el),matmul(el,grad)) +! qt=q+dot_product(grad,v2)*o2 ! <- Estimates what the new minimum will be +! Apply an under-relaxation in the first iteration: + if(it<=1)v2=v2*urc + ak=ak+matmul(basis,v2)! <- increment the parameter vector estimate +! Use the inverse cholesky factor to re-condition the basis. This is to make +! the next stencil-ellipse more closely share the shape of the elliptical +! contours of Q near its minumum -- essentially a preconditioning of the +! numerical optimization: + basis=matmul(basis,transpose(el)) +enddo +a=ak(1); k=ak(2) + +end subroutine get_bestesgt + +!============================================================================= +subroutine get_bestesg_inv(lam,m_arcx,m_arcy, a,k,arcx,arcy, q,ff)![get_bestesg_inv] +!============================================================================= +! A form of inverse of get_bestesg where the desired map-space edge +! coordinates, m_arcx and m_arcy, are input throught the argument +! list, and the A, K, arcx, and arcy (degrees) are output such that, +! if get_bestesg are called with these arcx and arcy as inputs, then +! m_arcx and m_arcx that would be returned are exactly the desired +! values. The A and K returned here are consistent also. +!============================================================================= +implicit none +real(dp),intent(in ):: lam,m_arcx,m_arcy +real(dp),intent(out):: a,k,arcx,arcy,q +logical, intent(out):: ff +!----------------------------------------------------------------------------- +integer(spi),parameter:: nit=40 ! <- Number of iterations allowed +real(dp), parameter:: crit=1.e-12_dp ! <- Convergence criterion +real(dp) :: rx,ry,m_arcxa,m_arcya +integer(spi) :: it +!============================================================================= +arcx=m_arcx*rtod; arcy=m_arcy*rtod ! < 1st guess (degrees) of arcx and arcy +do it=1,nit + call get_bestesg(lam,arcx,arcy, a,k,m_arcxa,m_arcya, q,ff) + if(ff)then + print'("In get_bestesg_inv; raised failure flag prevents completion")' + return + endif + rx=m_arcx/m_arcxa; ry=m_arcy/m_arcya + arcx=arcx*rx ; arcy=arcy*ry + if(abs(rx-u1)<=crit .and. abs(ry-u1)<=crit)return +enddo +print'("WARNING; in get_bestesg_inv;")' +print'("full convergence unattained after",i3," iterations")',nit +print'("Residual proportionate mismatch of arcx and of arcy:",2(1x,e12.5))',& + rx-u1,ry-u1 +end subroutine get_bestesg_inv + +!============================================================================= +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 points 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 + +end module pesg + diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pfun.f90 b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pfun.f90 new file mode 100644 index 000000000..9279dfc34 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pfun.f90 @@ -0,0 +1,218 @@ +! +! ********************************* +! * module pfun * +! * R. J. Purser * +! * NCEP/EMC 2017 * +! ********************************* +! Direct dependencies: +! Modules: pkind +! +!============================================================================= +module pfun +!============================================================================= +use pkind, only: sp,dp +implicit none +private +public:: gd,gdi,hav,havh,ahav,ahavh,sech,sechs,atanh + +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 + +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 + +end module pfun diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pietc.f90 b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pietc.f90 new file mode 100644 index 000000000..b3c27e036 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pietc.f90 @@ -0,0 +1,96 @@ +! +!============================================================================= +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/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pietc_s.f90 b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pietc_s.f90 new file mode 100644 index 000000000..6831d6667 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pietc_s.f90 @@ -0,0 +1,95 @@ +! +!============================================================================= +module pietc_s +!============================================================================= +! R. J. Purser (jim.purser@noaa.gov) 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. +!============================================================================= +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/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pkind.f90 b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pkind.f90 new file mode 100644 index 000000000..456f16b39 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_esg_grid.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/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat.f90 b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat.f90 new file mode 100644 index 000000000..2920bbd31 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat.f90 @@ -0,0 +1,1097 @@ +! +! ********************************************** +! * MODULE pmat * +! * R. J. Purser, NOAA/NCEP/EMC 1993 * +! * and Tsukasa Fujita, visiting scientist * +! * from JMA. * +! * Major modifications: 2002, 2009, 2012 * +! * jim.purser@noaa.gov * +! * * +! ********************************************** +! +! 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/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat2.f90 b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat2.f90 new file mode 100644 index 000000000..fde52673e --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat2.f90 @@ -0,0 +1,1267 @@ +! +! ********************************************** +! * MODULE pmat2 * +! * R. J. Purser, NOAA/NCEP/EMC 1994/1999 * +! * jim.purser@noaa.gov * +! * Tsukasa Fujita (JMA) 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. +! +! Programmers: R. J. Purser and T. Fujita +! National Centers for Environmental Prediction. +! Last modified (Purser): January 6th 2005 +! added nonredundant ldltb and ltdlbv routines for symmetric matrices, +! and remove obsolescent routines. +! January 6rd 2014 +! +! 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/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat4.f90 b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat4.f90 new file mode 100644 index 000000000..1e03e7d11 --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat4.f90 @@ -0,0 +1,2060 @@ +! +! ********************************************** +! * MODULE pmat4 * +! * R. J. Purser, NOAA/NCEP/EMC Oct 2005 * +! * 18th May 2012 * +! * jim.purser@noaa.gov * +! * * +! ********************************************** +! +! 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) 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/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/psym2.f90 b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/psym2.f90 new file mode 100644 index 000000000..dbdb92fde --- /dev/null +++ b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/psym2.f90 @@ -0,0 +1,537 @@ +! *********************************** +! * module psym2 * +! * R. J. Purser * +! * NOAA/NCEP/EMC September 2018 * +! * jim.purser@noaa.gov * +! *********************************** +! +! 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 +! Module: pkind, pietc +! +!============================================================================= +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 logsym2d_e; module procedure logsym2d_e; end interface +interface logsym2d_t; module procedure logsym2d_t; 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)) Date: Fri, 19 Jun 2020 14:32:40 +0000 Subject: [PATCH 22/38] feature/regional_grid This commit references NOAA-EMC#4. Add latest updates from Dusan's regional workflow branch. --- .../tools/regional_esg_grid.fd/pesg.f90 | 1670 +++++++++++------ .../tools/regional_esg_grid.fd/pfun.f90 | 69 +- .../tools/regional_esg_grid.fd/psym2.f90 | 131 +- .../regional_esg_grid.f90 | 6 +- 4 files changed, 1163 insertions(+), 713 deletions(-) diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pesg.f90 b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pesg.f90 index 5dc96b5ec..862d02b07 100644 --- a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pesg.f90 +++ b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pesg.f90 @@ -3,9 +3,9 @@ ! * pesg.f90 * ! * R. J. Purser * ! * NOAA/NCEP/EMC * -! * May 2020 * +! * May 2020 * ! * * -! * jim.purser@noaa.gov * +! * jim.purser@noaa.gov * ! *********************** ! Suite of routines to perform the 2-parameter family of Extended ! Schmidt Gnomonic (ESG) regional grid mappings, and to optimize the @@ -23,36 +23,48 @@ module pesg !============================================================================= use pkind, only: spi,dp -use pietc, only: F,T,u0,u1,u2,o2,rtod,dtor,pih +use pietc, only: F,T,u0,u1,u2,o2,rtod,dtor,pih,pi2 implicit none private -public :: xctoxs,xstoxc,xstoxt,xttoxs,xttoxm,zttozm,zmtozt,xctoxm_ak,xmtoxc_ak,& - getedges,get_qq,get_qofmap,get_bestesg,get_bestesg_inv, & - hgrid_ak_rr,hgrid_ak_rc,hgrid_ak_dd,hgrid_ak_dc,hgrid_ak -interface xctoxs; module procedure xctoxs; end interface -interface xstoxc; module procedure xstoxc; end interface -interface xstoxt; module procedure xstoxt; end interface -interface xttoxs; module procedure xttoxs; end interface -interface xttoxm; module procedure xttoxm; end interface -interface zttozm; module procedure zttozm; end interface -interface zmtozt; module procedure zmtozt; end interface -interface xctoxm_ak; module procedure xctoxm_ak; end interface -interface xmtoxc_ak; module procedure xmtoxc_ak; end interface -interface getedges; module procedure getedges; end interface -interface get_wxy; module procedure get_wxy; end interface -interface get_qq; module procedure get_qqw,get_qqt; end interface -interface get_qofmap; module procedure get_qofmap; end interface -interface get_bestesg; module procedure get_bestesg; end interface -interface get_bestesgt; module procedure get_bestesgt; end interface -interface get_bestesg_inv;module procedure get_bestesg_inv; 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 +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 + +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 !============================================================================= @@ -88,58 +100,131 @@ subroutine xstoxc(xs,xc,xcd)! [xstoxc] 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(kappa,xs,xt,ff)! [xstoxt] +subroutine xstoxt(k,xs,xt,ff)! [xstoxt] !============================================================================= ! Inverse of xttoxs. !============================================================================= implicit none -real(dp), intent(in ):: kappa +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=kappa*(xs(1)*xs(1)+xs(2)*xs(2)); sc=u1-s +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(kappa,xt,xs,xsd,ff)! [xttoxs] -!============================================================================== +!============================================================================= +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 ):: kappa +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):: s,sp,rsp,rspp,rspps,rspdx,rspdy -!============================================================================== -s=kappa*(xt(1)*xt(1) + xt(2)*xt(2)); sp=u1+s +!----------------------------------------------------------------------------- +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) -rspp=u1+rsp -rspps=rspp**2 -xs=xt/rspp -rspdx=kappa*xt(1)/rsp -rspdy=kappa*xt(2)/rsp -xsd(1,1)=u1/rspp -xt(1)*rspdx/rspps -xsd(1,2)= -xt(1)*rspdy/rspps -xsd(2,1)= -xt(2)*rspdx/rspps -xsd(2,2)=u1/rspp -xt(2)*rspdy/rspps +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] +subroutine xttoxm(a,xt,xm,ff)! [xttoxm] !============================================================================= ! Inverse of xmtoxt -!============================================================================ +!============================================================================= implicit none real(dp), intent(in ):: a real(dp),dimension(2),intent(in ):: xt @@ -151,11 +236,11 @@ subroutine xttoxm(a,xt,xm,ff)! [xttoxm] 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] -!============================================================================== +!============================================================================= +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 @@ -164,9 +249,31 @@ subroutine xmtoxt(a,xm,xt,xtd,ff)! [xmtoxt] 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] @@ -188,19 +295,19 @@ subroutine zttozm(a,zt,zm,ff)! [zttozm] endif end subroutine zttozm -!============================================================================== -subroutine zmtozt(a,zm,zt,ztd,ff)! [zmtozt] -!============================================================================== +!============================================================================= +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(a4)stop 'In get_wxy; ncor is out of bounds' -if(ncor>=min(nxh,nyh))stop 'In get_wxy; ncor is too large for this small grid' -! the wx and wy are the weight coefficients for an unnormalized -! extended trapezoidal integration. The end correction coefficients can -! be found by staggering, then summing, the Adams-Moulton coefficients -! at both ends. -wx=u1; wx(0)=o2; wx(nxh:nxh-ncor:-1)=cor -wy=u1; wy(0)=o2; wy(nyh:nyh-ncor:-1)=cor -wxy=outer_product(wx,wy); wxy=wxy/sum(wxy) -end subroutine get_wxy - -!============================================================================= -subroutine get_qqw(nxh,nyh,ncor,j0xy,tw,p,q)! [get_qq] -!============================================================================= -! Like get_qqt, except the square norm involved in the definition of Q is -! modified by including a "trace-weight" proportion, tw, of the squared-trace. -! (Elsewhere tw is also known as "lambda".) -! In the elasticity analogue, this extra degree of freedom is like being -! able to include a nontrivial Poisson ratio defining the elastic modulus. +real(dp),dimension(2,2):: el,g !============================================================================= -use pmat4, only: outer_product -use psym2, only: logsym2,expsym2 +g=matmul(transpose(j0),j0) +call logsym2(g,el); el=el*o2 +v1=el(1,1)**2+u2*el(1,2)**2+el(2,2)**2 +v2=el(1,1) +v3=el(2,2) +v4=(el(1,1)+el(2,2))**2 +end subroutine get_qx +!============================================================================= +subroutine get_qxd(j0,j0d, v1,v2,v3,v4,v1d,v2d,v3d,v4d)! [get_qx] +!============================================================================= +! From a jacobian matrix, j0, and its derivative, j0d, get a sufficient set +! of v.. diagnostics such that, from average of these diagnostics, we can +! later compute the collective variance of Q and its derivative. +!============================================================================= +use psym2, only: logsym2 implicit none -integer(spi), intent(in ):: nxh,nyh,ncor -real(dp),dimension(3,2,0:nxh,0:nyh),intent(in ):: j0xy -real(dp), intent(in ):: tw -real(dp),dimension(2,2), intent(inout):: p -real(dp), intent( out):: q +real(dp),dimension(3,2), intent(in ):: j0 +real(dp),dimension(3,2,2),intent(in ):: j0d +real(dp), intent(out):: v1,v2,v3,v4 +real(dp),dimension(2), intent(out):: v1d,v2d,v3d,v4d !----------------------------------------------------------------------------- -integer(spi),parameter :: nit=5 -real(dp),parameter :: acrit=1.e-8_dp,dpx=.0099e0_dp -real(dp),dimension(0:nxh,0:nyh):: wxy -real(dp),dimension(3,2) :: j0,j -real(dp),dimension(2,2) :: el,pf,elp,elmean,g,ppx,pmx,ppy,pmy -real(dp),dimension(2) :: hess,grad -real(dp) :: anorm,q00,qpx,qmx,qpy,qmy,c,w,twc -integer(spi) :: ix,iy,it -!============================================================================= -call get_wxy(nxh,nyh,ncor,wxy)! <- get 2D extended trapezoidal averaging wts -twc=u1-tw -if(p(1,1)==u0)then; p=u0; p(1,1)=u1; p(2,2)=u1; endif -! Iteratively calibrate preconditioner, p, to make elmean vanish: -anorm=u1 -do it=1,nit - elmean=u0 - q=u0 - do iy=0,nyh; do ix=0,nxh - j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) -! Precondition the Jacobian using latest iteration of P: - j=matmul(j0,p) -! Find the Gram matrix, G, implied by the column vectors of the new J: - g=matmul(transpose(j),j) -! Find the matrix logarithm, L = 0.5*log(G), contributions to elmean and q: - call logsym2(g,el); el=el*o2; elmean=elmean+w*el - q=q+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) - enddo; ; enddo - if(anormnit)& -print'("WARNING: In get_qqw, relatively inferior convergence; anorm=",1x,e12.5)',anorm -q00=q -ppx=p; ppx(1,1)=ppx(1,1)*(u1+dpx);qpx=u0 -pmx=p; pmx(1,1)=pmx(1,1)*(u1-dpx);qmx=u0 -ppy=p; ppy(2,2)=ppy(2,2)*(u1+dpx);qpy=u0 -pmy=p; pmy(2,2)=pmy(2,2)*(u1-dpx);qmy=u0 -do iy=0,nyh; do ix=0,nxh - j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) - j=matmul(j0,ppx); g=matmul(transpose(j),j) - call logsym2(g,el);el=el*o2;qpx=qpx+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) - j=matmul(j0,pmx); g=matmul(transpose(j),j) - call logsym2(g,el);el=el*o2;qmx=qmx+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) - j=matmul(j0,ppy); g=matmul(transpose(j),j) - call logsym2(g,el);el=el*o2;qpy=qpy+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) - j=matmul(j0,pmy); g=matmul(transpose(j),j) - call logsym2(g,el);el=el*o2;qmy=qmy+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) -enddo; enddo -! Estimate a (diagonal) Hessian matrix and a gradient vector: -hess=(/ (qpx-u2*q00+qmx)/dpx**2, (qpy-u2*q00+qmy)/dpx**2 /) -hess=(/8._dp,8._dp/) -grad=(/ (qpx-qmx)/(u2*dpx) , (qpy-qmy)/(u2*dpx) /) -! If the hessian is positive, polish p with a final Newton iteration: -if(hess(1)>u0 .and. hess(2)>u0)then - c=u1-grad(1)/hess(1); p(:,1)=p(:,1)*c - c=u1-grad(2)/hess(2); p(:,2)=p(:,2)*c -endif - -! and calculate the new q. Keep it only if it's numerically smaller than before: -q00=0 -do iy=0,nyh; do ix=0,nxh - j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) - j=matmul(j0,p); g=matmul(transpose(j),j) - call logsym2(g,el);el=el*o2;q00=q00+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) -enddo; enddo -if(q00nit)print'(" WARNING: In get_qqt, relatively inferior convergence")' - -q00=q -ppx=p; ppx(1,1)=ppx(1,1)*(1+dpx);qpx=0 -pmx=p; pmx(1,1)=pmx(1,1)*(1-dpx);qmx=0 -ppy=p; ppy(2,2)=ppy(2,2)*(1+dpx);qpy=0 -pmy=p; pmy(2,2)=pmy(2,2)*(1-dpx);qmy=0 -do iy=0,nyh; do ix=0,nxh - j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) - j=matmul(j0,ppx); g=matmul(transpose(j),j) - call logsym2(g,el); el=el/2; qpx=qpx+w*sum(el**2) - j=matmul(j0,pmx); g=matmul(transpose(j),j) - call logsym2(g,el); el=el/2; qmx=qmx+w*sum(el**2) - j=matmul(j0,ppy); g=matmul(transpose(j),j) - call logsym2(g,el); el=el/2; qpy=qpy+w*sum(el**2) - j=matmul(j0,pmy); g=matmul(transpose(j),j) - call logsym2(g,el); el=el/2; qmy=qmy+w*sum(el**2) -enddo; enddo -! Estimate a (diagonal) Hessian matrix and a gradient vector: -hess=(/ (qpx-2*q00+qmx)/dpx**2, (qpy-2*q00+qmy)/dpx**2 /) -grad=(/ (qpx-qmx)/(2*dpx) , (qpy-qmy)/(2*dpx) /) - -! If the hessian is positive, polish the final p with a final Newton iteration: -if(hess(1)>0 .and. hess(2)>0.)then - c=u1-grad(1)/hess(1); p(:,1)=p(:,1)*c - c=u1-grad(2)/hess(2); p(:,2)=p(:,2)*c -endif +call get_qofv(lam,v1,v2,v3,v4, q)! <- Q(lam) based on the v1,v2,v3,v4 +call get_qofv(lam,v2,v3, v1d,v2d,v3d,v4d, qdak)! <- Derivative of Q wrt ak +!------ +! Derivatives of ga wrt ak, and of q and ga wrt ma: +gadma=u0! <- needed because only diagonal elements are filled +do i=1,2 + ic=3-i + xm=0; xm(i)=ma(i) + call xmtoxc_ak(ak,xm,xc,xcd,xc1,xcd1,ff); if(ff)return + ga(i)=atan2(xc(i),xc(3))*rtod + gadak(i,:)=(xc(3)*xc1(i,:)-xc(i)*xc1(3,:))*rtod + gadma(i,i)=(xc(3)*xcd(i,i)-xc(i)*xcd(3,i))*rtod -! and calculate the new q. Keep it only if is numerically smaller than before: -q00=0 -do iy=0,nyh; do ix=0,nxh - j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) - j=matmul(j0,p); g=matmul(transpose(j),j) - call logsym2(g,el); el=el*o2; q00=q00+w*sum(el**2) -enddo; enddo -if(q00=u1 -if(ff)then - print'("In get_bestesg; invalid optimization criterion parameter, lam")' - return -endif -ff= arcx<=u0 .or. arcy<=u0 -if(ff)then - print'("In get_bestesg; a nonpositive domain parameter, arcx or arcy")' - return -endif -! Make tarcx the longer of the two semi-axes of the domain: -flip=arcy>arcx -if(flip)then; tarcx=arcy; tarcy=arcx ! <- switch -else ; tarcx=arcx; tarcy=arcy ! <- don't switch -endif -asp=tarcy/tarcx ! <- Domain aspect ratio that does not exceed one -sarcx=tarcx/darc -i0=floor(sarcx); i1=i0+1; wi0=i1-sarcx; wi1=sarcx-i0 -ff=i1>marc -if(ff)then - print'("In get_bestesg; domain length too large")'; return -endif -asplim=u1 ! <- Default aspect ratio limit for small tarcx -if(i0>=larc)then ! Interpolate aspect limit for this large tarcx from the table: - slam=lam/dlam - j0=floor(slam) ; j1=j0+1; wj0=j1-slam; wj1=slam -j0 - asplim=(asplims(j0,i0)*wi0+asplims(j0,i1)*wi1)*wj0 + & - (asplims(j1,i0)*wi0+asplims(j1,i1)*wi1)*wj1 -endif -ff=asp>asplim -if(ff)then - print'("In get_bestesg; domain width too large for given domain length")' - return -endif -call get_bestesgt(lam,asp,tarcx, A,K,tm_arcx,tm_arcy,q,ff) -if(ff)return -if(flip)then; m_arcx=tm_arcy; m_arcy=tm_arcx -else ; m_arcx=tm_arcx; m_arcy=tm_arcy -endif -end subroutine get_bestesg - -!============================================================================= -subroutine get_bestesgt(lam,asp,arcx, a,k,m_arcx,m_arcy,q,ff)! [get_betsesgt] -!============================================================================= -! With prescribed optimization criterion parameter, lam ("lambda"), -! aspect ratio, asp (0.1 < asp <= 1.), major semi-arc, in degrees, of arcx, -! return the best Extended Schmidt-Gnomonic (ESG) mapping parameters, A and K, -! for the rectangular domain whose edge midpoints are distant arcx and asp*arcx -! from its center. -! Also, return the map-space x and y coordinates, m_arcx, m_arcy, of -! the domain edges in the positive directions. -! The optimality criterion, Q(A,K), which this routine aims to minimize, -! is provided upon return. However A and K are independenly scaled, the contours -! Q are highly elliptical; the differencing stencil is adjusted to mimic this -! stretching to preserve good numerical conditioning of the calculations and, we -! hope, tl thereby ensure an accurate and robust estimation of the location of -! the minimum. -! If the process fails for any reason (such as parameter combinations, lam, asp, -! arcx for which no minimum of Q in the proper interior of the valid space -! of these parameters exists), then the failure flag, FF, is raised (.true.) -! and the output parameters are then of course meaningless. -!============================================================================= -use pietc, only: u5,o5,s18,s36,s54,s72,ms18,ms36,ms54,ms72,pi2 -use psym2, only: chol2 +real(dp):: lamc +!============================================================================= +lamc=u1-lam +q=lamc*(v1-(v2**2+v3**2)) +lam*(v4 -(v2+v3)**2) +end subroutine get_qofv +!============================================================================= +subroutine get_qofvd(lam, v2,v3, v1d,v2d,v3d,v4d, qd)! [get_qofv] +!============================================================================= +! Like get_qofv, but for (only) the 2-vector derivatives of Q. Note that +! the quadratic diagnostics v1 and v4 do not participate in this formula. +!============================================================================= implicit none -real(dp),intent(in ):: lam,arcx,asp -real(dp),intent(out):: a,k,m_arcx,m_arcy,q -logical, intent(out):: ff +real(dp), intent(in ):: lam,v2,v3 +real(dp),dimension(2),intent(in ):: v1d,v2d,v3d,v4d +real(dp),dimension(2),intent(out):: qd +!----------------------------------------------------------------------------- +real(dp):: lamc +!============================================================================= +lamc=u1-lam +qd=lamc*(v1d-u2*(v2d*v2+v3d*v3))+lam*(v4d-u2*(v2d+v3d)*(v2+v3)) +end subroutine get_qofvd +!============================================================================= +subroutine get_qsofvs(n,lam,v1s,v2s,v3s,v4s, qs)! [get_qofv] +!============================================================================= +implicit none +integer(spi), intent(in ):: n +real(dp), intent(in ):: lam +real(dp),dimension(n),intent(in ):: v1s,v2s,v3s,v4s +real(dp),dimension(n),intent(out):: qs +!----------------------------------------------------------------------------- +real(dp):: lamc +!============================================================================= +lamc=u1-lam +qs=lamc*(v1s-(v2s**2+v3s**2)) +lam*(v4s -(v2s+v3s)**2) +end subroutine get_qsofvs + +!============================================================================= +subroutine guessak_map(asp,tmarcx,ak)! [guessak_map] +!============================================================================= +! Given an aspect ratio, asp<=1, and major semi-axis, arc, in map-space +! nondimensional units, return a first guess for the parameter vector, ak, +! approximately optimal for the domain of the given dimensions. +!============================================================================= +implicit none +real(dp), intent(in ):: asp,tmarcx +real(dp),dimension(2),intent(out):: ak !----------------------------------------------------------------------------- -integer(spi),parameter :: narc=11,nasp=10,nit=8,nang=5 -real(dp),parameter :: eps=1.e-7_dp,u2o5=u2*o5,darc=10._dp+eps,& - dasp=.1_dp+eps,dang=pi2*o5,r=0.0001_dp,rr=r*r, & - urc=.4_dp, & ! <- Under-relaxation coefficient - enxyq=10000._dp! ~ pts in trial grid quadrant -real(dp),parameter :: f18=u2o5*s18,f36=u2o5*s36,f54=u2o5*s54,f72=u2o5*s72,& - mf18=-f18,mf36=-f36,mf54=-f54,mf72=-f72 !<- (Fourier) -real(dp),dimension(0:4,0:4) :: em5 ! <- Fourier matrix for 5 points -real(dp),dimension(nasp,0:narc):: adarc,kdarc ! < 1st guess tables of A and K. -real(dp),dimension(0:nang-1) :: qs -real(dp),dimension(2,0:nang-1) :: aks -real(dp),dimension(2) :: grad,v2,ak -real(dp),dimension(2,2) :: hess,el,basis0,basis -real(dp),dimension(3) :: xcedgex,xcedgey -real(dp),dimension(2) :: xmedgex,xmedgey -real(dp) :: ang,sarcx,sasp,wx0,wx1,wa0,wa1,qold -integer(spi) :: i,it,iarcx0,iasp0,iarcx1,iasp1,& - nxh,nyh +real(dp):: gmarcx +!============================================================================= +gmarcx=tmarcx*rtod +call guessak_geo(asp,gmarcx,ak) +end subroutine guessak_map + +!============================================================================= +subroutine guessak_geo(asp,arc,ak)! [guessak_geo] +!============================================================================= +! Given an aspect ratio, asp<=1, and major semi-axis, arc, in geographical +! (degree) units measured along the rectangle's median, return a first guess +! for the parameter vector, ak, approximately optimal for the domain of the +! given dimensions. +!============================================================================= +implicit none +real(dp), intent(in ):: asp,arc +real(dp),dimension(2),intent(out):: ak +!----------------------------------------------------------------------------- +integer(spi),parameter :: narc=11,nasp=10! <- Table index bounds +real(dp), parameter :: eps=1.e-7_dp,darc=10._dp+eps,dasp=.1_dp+eps +real(dp),dimension(nasp,0:narc):: adarc,kdarc +real(dp) :: sasp,sarc,wx0,wx1,wa0,wa1 +integer(spi) :: iasp0,iasp1,iarc0,iarc1 !------------------------ ! Tables of approximate A (adarc) and K (kdarc), valid for lam=0.8, for aspect ratio, ! asp, at .1, .2, .3, .4, .5, .6, .7, .8, 1. and major semi-arc, arcx, at values, @@ -697,7 +735,7 @@ subroutine get_bestesgt(lam,asp,arcx, a,k,m_arcx,m_arcy,q,ff)! [get_betsesgt] ! from a computation at 3 degrees, since zero would not make sense). ! The 100 degree rows are repeated as the 110 degree entries deliberately to pad the ! table into the partly forbidden parameter space to allow skinny domains of up to -! 110 degree semi-length to be validly endowed with optimal A and K: +! 110 degree semi-length to be validly endowed with optimal A and K: data adarc/ & -.450_dp,-.328_dp,-.185_dp,-.059_dp,0.038_dp,0.107_dp,0.153_dp,0.180_dp,0.195_dp,0.199_dp,& -.452_dp,-.327_dp,-.184_dp,-.058_dp,0.039_dp,0.108_dp,0.154_dp,0.182_dp,0.196_dp,0.200_dp,& @@ -725,128 +763,320 @@ subroutine get_bestesgt(lam,asp,arcx, a,k,m_arcx,m_arcy,q,ff)! [get_betsesgt] -.418_dp,-.373_dp,-.322_dp,-.275_dp,-.236_dp,-.204_dp,-.178_dp,-.156_dp,-.139_dp,-.127_dp,& -.324_dp,-.296_dp,-.261_dp,-.229_dp,-.200_dp,-.174_dp,-.152_dp,-.133_dp,-.117_dp,-.104_dp,& -.324_dp,-.296_dp,-.261_dp,-.229_dp,-.200_dp,-.174_dp,-.152_dp,-.133_dp,-.117_dp,-.104_dp/ - -data em5/o5, u2o5, u0, u2o5, u0, & ! <- The Fourier matrix for 5 points. Applied to - o5, f18, f72, mf54, f36, & ! the five 72-degree spaced values in a column- - o5, mf54, f36, f18, mf72, & ! vector, the product vector has the components, - o5, mf54, mf36, f18, f72, & ! wave-0, cos and sin wave-1, cos and sin wave-2. - o5, f18, mf72, mf54, mf36/ - -data basis0/0.1_dp,u0, 0.3_dp,0.3_dp/! <- initial basis for orienting (a,k) differencing -!============================================================================ +!============================================================================= sasp=asp/dasp iasp0=floor(sasp); wa1=sasp-iasp0 iasp1=iasp0+1; wa0=iasp1-sasp -sarcx=arcx/darc -iarcx0=floor(sarcx); wx1=sarcx-iarcx0 -iarcx1=iarcx0+1; wx0=iarcx1-sarcx -if(iasp0 <1 .or. iasp1 >nasp)stop 'Aspect ratio out of range' -if(iarcx0<0 .or. iarcx1>narc)stop 'Major semi-arc is out of range' -nxh=nint(sqrt(enxyq/asp))! < These nxh and nyh ensure nearly -nyh=nint(sqrt(enxyq*asp))! square trial grid cells, and about enxyq points in total. -call getedges(arcx,asp*arcx, xcedgex,xcedgey) +sarc=arc/darc +iarc0=floor(sarc); wx1=sarc-iarc0 +iarc1=iarc0+1; wx0=iarc1-sarc +if(iasp0<1 .or. iasp1>nasp)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,iarcx0)+wa1*adarc(iasp1,iarcx0))+ & - wx1*(wa0*adarc(iasp0,iarcx1)+wa1*adarc(iasp1,iarcx1)), & - wx0*(wa0*kdarc(iasp0,iarcx0)+wa1*kdarc(iasp1,iarcx0))+ & - wx1*(wa0*kdarc(iasp0,iarcx1)+wa1*kdarc(iasp1,iarcx1))/) -basis=basis0 ! <- initial the basis to a representative guess. -qold=100._dp ! <- initialize qold to a meaningless large value to force at least one - ! complete Newton iteration to occur. +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_qofmap(nxh,nyh,ak(1),ak(2),lam,xcedgex,xcedgey,& - q,xmedgex,xmedgey,ff) + call get_meanq(ngh,lam,xg,wg,ak,ma,q,qdak,qdma,gat,gadak,gadma,ff) if(ff)return - if(q>=qold)exit ! <-Assume this condition indicates early convergence - m_arcx=xmedgex(1) - m_arcy=xmedgey(2) - qold=q - + 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 - v2=(/cos(ang),sin(ang)/)*r ! points on a circle of radius r ... - aks(:,i)=ak+matmul(basis,v2) ! ... become points on an ellipse. -! Get quality, qs(i) - call get_qofmap(nxh,nyh,aks(1,i),aks(2,i),lam,xcedgex,xcedgey,& - qs(i),xmedgex,xmedgey,ff) - enddo - if(ff)return -! Recover gradient and hessian estimates, normalized by q, from all -! 6 samples, q, qs. These are wrt the basis, not (a,k) directly. + 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 get_bestesg_inv(lam,m_arcx,m_arcy, a,k,arcx,arcy, q,ff)![get_bestesg_inv] +subroutine bestesg_map(lam,marcx,marcy, a,k,garcx,garcy,q,ff) ![bestesg_map] !============================================================================= -! A form of inverse of get_bestesg where the desired map-space edge -! coordinates, m_arcx and m_arcy, are input throught the argument -! list, and the A, K, arcx, and arcy (degrees) are output such that, -! if get_bestesg are called with these arcx and arcy as inputs, then -! m_arcx and m_arcx that would be returned are exactly the desired -! values. The A and K returned here are consistent also. +! 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,m_arcx,m_arcy -real(dp),intent(out):: a,k,arcx,arcy,q -logical, intent(out):: ff +real(dp),intent(in ):: lam,marcx,marcy +real(dp),intent(out):: a,k,garcx,garcy,q +logical ,intent(out):: FF !----------------------------------------------------------------------------- -integer(spi),parameter:: nit=40 ! <- Number of iterations allowed -real(dp), parameter:: crit=1.e-12_dp ! <- Convergence criterion -real(dp) :: rx,ry,m_arcxa,m_arcya -integer(spi) :: it -!============================================================================= -arcx=m_arcx*rtod; arcy=m_arcy*rtod ! < 1st guess (degrees) of arcx and arcy +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_bestesg(lam,arcx,arcy, a,k,m_arcxa,m_arcya, q,ff) - if(ff)then - print'("In get_bestesg_inv; raised failure flag prevents completion")' - return + 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 - rx=m_arcx/m_arcxa; ry=m_arcy/m_arcya - arcx=arcx*rx ; arcy=arcy*ry - if(abs(rx-u1)<=crit .and. abs(ry-u1)<=crit)return + 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] @@ -865,11 +1095,12 @@ subroutine hgrid_ak_rr(lx,ly,nx,ny,A,K,plat,plon,pazi, & ! [hgrid_ak_rr] ! 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 +! 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. . +! 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 @@ -936,7 +1167,6 @@ subroutine hgrid_ak_rr(lx,ly,nx,ny,A,K,plat,plon,pazi, & ! [hgrid_ak_rr] 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) @@ -946,16 +1176,17 @@ subroutine hgrid_ak_rr_c(lx,ly,nx,ny,a,k,plat,plon,pazi, & ! [hgrid_ak_rr] ! 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. +! 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 points thus +! 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. +! 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, @@ -1150,11 +1381,12 @@ subroutine hgrid_ak_rc(lx,ly,nx,ny,A,K,plat,plon,pazi, & ! [hgrid_ak_rc] ! 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 +! 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. . +! 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 @@ -1224,17 +1456,18 @@ 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 +! 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 +! 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), 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 @@ -1259,8 +1492,8 @@ subroutine hgrid_ak_dd_c(lx,ly,nx,ny,a,k,pdlat,pdlon,pdazi, &! [hgrid_ak_dd] !============================================================================= implicit none integer(spi), intent(in ):: lx,ly,nx,ny -real(dp), intent(in ):: a,k,pdlat,pdlon,pdazi, & - delx,dely +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 @@ -1287,12 +1520,13 @@ 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 +! 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 +! occurs anywhere in these calculations. !============================================================================ implicit none integer(spi),intent(in ):: lx,ly,nx,ny @@ -1353,7 +1587,7 @@ subroutine hgrid_ak_c(lx,ly,nx,ny,a,k,plat,plon,pazi, & ! [hgrid_ak] ! 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, & @@ -1380,5 +1614,233 @@ subroutine hgrid_ak_c(lx,ly,nx,ny,a,k,plat,plon,pazi, & ! [hgrid_ak] 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/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pfun.f90 b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pfun.f90 index 9279dfc34..6a60fe359 100644 --- a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pfun.f90 +++ b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pfun.f90 @@ -5,7 +5,7 @@ ! * NCEP/EMC 2017 * ! ********************************* ! Direct dependencies: -! Modules: pkind +! Modules: pkind, pietc_s, pietc ! !============================================================================= module pfun @@ -13,7 +13,8 @@ module pfun use pkind, only: sp,dp implicit none private -public:: gd,gdi,hav,havh,ahav,ahavh,sech,sechs,atanh +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 @@ -24,6 +25,10 @@ module pfun 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 @@ -215,4 +220,64 @@ function sechs_d(x)result(r)! [sechs] 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/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/psym2.f90 b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/psym2.f90 index dbdb92fde..4f112da52 100644 --- a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/psym2.f90 +++ b/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/psym2.f90 @@ -11,7 +11,8 @@ ! In addition, we include a simple cholesky routine ! ! DIRECT DEPENDENCIES -! Module: pkind, pietc +! Library: pfun +! Module: pkind, pietc, pfun ! !============================================================================= module psym2 @@ -33,9 +34,7 @@ module psym2 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 logsym2d_e; module procedure logsym2d_e; end interface -interface logsym2d_t; module procedure logsym2d_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 @@ -343,7 +342,7 @@ subroutine expsym2d_t(x,z,zd)! [expsym2d_t] real(dp),dimension(2,2), intent(out):: z real(dp),dimension(2,2,2,2),intent(out):: zd !----------------------------------------------------------------------------- -integer,parameter :: nit=100 ! number of iterative increments allowed +integer(spi),parameter :: nit=100 ! number of iterative increments allowed real(dp),parameter :: crit=1.e-17_dp real(dp),dimension(2,2) :: xp,xd,xpd real(dp) :: c @@ -379,15 +378,16 @@ subroutine logsym2(em,logem)! [logsym2] !============================================================================= ! Get the log 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):: logem !----------------------------------------------------------------------------- real(dp),dimension(2,2):: vv,oo -integer :: i +integer(spi) :: i !============================================================================= call eigensym2(em,vv,oo) do i=1,2 - if(oo(i,i)<=0)stop 'In logsym2; matrix em is not positive definite' + if(oo(i,i)<=u0)stop 'In logsym2; matrix em is not positive definite' oo(i,i)=log(oo(i,i)) enddo logem=matmul(vv,matmul(oo,transpose(vv))) @@ -397,108 +397,33 @@ subroutine logsym2d(x,z,zd)! [logsym2] !============================================================================= ! General routine to evaluate the logarithm, z=log(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 -! log, 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). -!============================================================================= -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),parameter :: o8=u1/8 -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=log(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 Date: Tue, 30 Jun 2020 19:57:27 +0000 Subject: [PATCH 23/38] feature/regional_grid This commit references NOAA-EMC#4. Remove Jim's original regional code. Only retain his ESG code. --- driver_scripts/driver_grid.cray.sh | 8 +- driver_scripts/driver_grid.dell.sh | 8 +- driver_scripts/driver_grid.hera.sh | 8 +- driver_scripts/driver_grid.jet.sh | 8 +- sorc/fre-nctools.fd/CMakeLists.txt | 1 - .../tools/regional_grid.fd/CMakeLists.txt | 18 - .../tools/regional_grid.fd/gen_schmidt.f90 | 477 ---- .../tools/regional_grid.fd/hgrid_ak.f90 | 206 -- .../tools/regional_grid.fd/pietc.f90 | 95 - .../tools/regional_grid.fd/pkind.f90 | 8 - .../tools/regional_grid.fd/pmat.f90 | 1082 --------- .../tools/regional_grid.fd/pmat4.f90 | 1924 ----------------- .../tools/regional_grid.fd/pmat5.f90 | 791 ------- .../tools/regional_grid.fd/psym2.f90 | 498 ----- .../tools/regional_grid.fd/regional_grid.f90 | 158 -- .../tools/regional_grid.fd/regional_grid.nml | 100 - ush/fv3gfs_driver_grid.sh | 14 +- ush/fv3gfs_filter_topo.sh | 2 +- ush/fv3gfs_make_grid.sh | 12 +- 19 files changed, 19 insertions(+), 5399 deletions(-) delete mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/CMakeLists.txt delete mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/gen_schmidt.f90 delete mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 delete mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/pietc.f90 delete mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/pkind.f90 delete mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/pmat.f90 delete mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/pmat4.f90 delete mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/pmat5.f90 delete mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/psym2.f90 delete mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/regional_grid.f90 delete mode 100644 sorc/fre-nctools.fd/tools/regional_grid.fd/regional_grid.nml diff --git a/driver_scripts/driver_grid.cray.sh b/driver_scripts/driver_grid.cray.sh index ccf3a2107..78a01628d 100755 --- a/driver_scripts/driver_grid.cray.sh +++ b/driver_scripts/driver_grid.cray.sh @@ -57,7 +57,7 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export gtype=regional2 # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=regional_esg # 'uniform', 'stretch', 'nest', or 'regional' if [ $gtype = uniform ]; then export res=96 @@ -77,7 +77,7 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then export iend_nest=166 # Ending i-direction index of nest grid in parent tile supergrid export jend_nest=164 # Ending j-direction index of nest grid in parent tile supergrid export halo=3 -elif [ $gtype = regional2 ] ; then +elif [ $gtype = regional_esg ] ; then export res=-999 # equivalent res is computed. export target_lon=-97.5 # Center longitude of grid export target_lat=35.5 # Center latitude of grid @@ -89,10 +89,6 @@ elif [ $gtype = regional2 ] ; then # direction is related to delx as follows: # distance = 2*delx*(circumf_Earth/360 deg) export dely=0.0585 # Grid spacing (in degrees) in the 'j' direction. - export a_param=0.21423 # 'a' parameter of the generalized gnomonic mapping - # centered at target_lon/lat. See Purser office note. - export k_param=-0.23209 # 'k' parameter of the generalized gnomonic mapping - # centered at target_lon/lat. See Purser office note. export halo=3 # number of row/cols for halo fi diff --git a/driver_scripts/driver_grid.dell.sh b/driver_scripts/driver_grid.dell.sh index 4ac2aac95..fc6dd0b59 100755 --- a/driver_scripts/driver_grid.dell.sh +++ b/driver_scripts/driver_grid.dell.sh @@ -59,7 +59,7 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export gtype=regional # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=regional_esg # 'uniform', 'stretch', 'nest', or 'regional' if [ $gtype = uniform ]; then export res=96 @@ -79,7 +79,7 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then export iend_nest=166 # Ending i-direction index of nest grid in parent tile supergrid export jend_nest=164 # Ending j-direction index of nest grid in parent tile supergrid export halo=3 -elif [ $gtype = regional2 ] ; then +elif [ $gtype = regional_esg ] ; then export res=-999 # equivalent res is computed. export target_lon=-97.5 # Center longitude of grid export target_lat=35.5 # Center latitude of grid @@ -91,10 +91,6 @@ elif [ $gtype = regional2 ] ; then # direction is related to delx as follows: # distance = 2*delx*(circumf_Earth/360 deg) export dely=0.0585 # Grid spacing (in degrees) in the 'j' direction. - export a_param=0.21423 # 'a' parameter of the generalized gnomonic mapping - # centered at target_lon/lat. See Purser office note. - export k_param=-0.23209 # 'k' parameter of the generalized gnomonic mapping - # centered at target_lon/lat. See Purser office note. export halo=3 # number of row/cols for halo fi diff --git a/driver_scripts/driver_grid.hera.sh b/driver_scripts/driver_grid.hera.sh index db6eaae92..a5000634f 100755 --- a/driver_scripts/driver_grid.hera.sh +++ b/driver_scripts/driver_grid.hera.sh @@ -59,7 +59,7 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export gtype=regional2 # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=regional_esg # 'uniform', 'stretch', 'nest', or 'regional' if [ $gtype = uniform ]; then export res=96 @@ -79,7 +79,7 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then export iend_nest=166 # Ending i-direction index of nest grid in parent tile supergrid export jend_nest=164 # Ending j-direction index of nest grid in parent tile supergrid export halo=3 # Lateral boundary halo -elif [ $gtype = regional2 ] ; then +elif [ $gtype = regional_esg ] ; then export res=-999 # equivalent res is computed. export target_lon=-97.5 # Center longitude of grid export target_lat=35.5 # Center latitude of grid @@ -91,10 +91,6 @@ elif [ $gtype = regional2 ] ; then # direction is related to delx as follows: # distance = 2*delx*(circumf_Earth/360 deg) export dely=0.0585 # Grid spacing (in degrees) in the 'j' direction. - export a_param=0.21423 # 'a' parameter of the generalized gnomonic mapping - # centered at target_lon/lat. See Purser office note. - export k_param=-0.23209 # 'k' parameter of the generalized gnomonic mapping - # centered at target_lon/lat. See Purser office note. export halo=3 # number of row/cols for halo fi diff --git a/driver_scripts/driver_grid.jet.sh b/driver_scripts/driver_grid.jet.sh index 3ee9bd8b1..3ecb7b997 100755 --- a/driver_scripts/driver_grid.jet.sh +++ b/driver_scripts/driver_grid.jet.sh @@ -60,7 +60,7 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export gtype=regional2 # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=regional_esg # 'uniform', 'stretch', 'nest', or 'regional' if [ $gtype = uniform ]; then export res=96 @@ -80,7 +80,7 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then export iend_nest=166 # Ending i-direction index of nest grid in parent tile supergrid export jend_nest=164 # Ending j-direction index of nest grid in parent tile supergrid export halo=3 # Lateral boundary halo -elif [ $gtype = regional2 ] ; then +elif [ $gtype = regional_esg ] ; then export res=-999 # equivalent resolution is computed export target_lon=-97.5 # Center longitude of grid export target_lat=35.5 # Center latitude of grid @@ -92,10 +92,6 @@ elif [ $gtype = regional2 ] ; then # direction is related to delx as follows: # distance = 2*delx*(circumf_Earth/360 deg) export dely=0.0585 # Grid spacing (in degrees) in the 'j' direction. - export a_param=0.21423 # 'a' parameter of the generalized gnomonic mapping - # centered at target_lon/lat. See Purser office note. - export k_param=-0.23209 # 'k' parameter of the generalized gnomonic mapping - # centered at target_lon/lat. See Purser office note. export halo=3 # number of row/cols for halo fi diff --git a/sorc/fre-nctools.fd/CMakeLists.txt b/sorc/fre-nctools.fd/CMakeLists.txt index 6a0c51673..353c4fb7c 100644 --- a/sorc/fre-nctools.fd/CMakeLists.txt +++ b/sorc/fre-nctools.fd/CMakeLists.txt @@ -5,5 +5,4 @@ add_subdirectory(tools/make_hgrid) add_subdirectory(tools/filter_topo) add_subdirectory(tools/shave.fd) add_subdirectory(tools/global_equiv_resol.fd) -add_subdirectory(tools/regional_grid.fd) add_subdirectory(tools/regional_esg_grid.fd) diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/CMakeLists.txt b/sorc/fre-nctools.fd/tools/regional_grid.fd/CMakeLists.txt deleted file mode 100644 index fd7f73eab..000000000 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/CMakeLists.txt +++ /dev/null @@ -1,18 +0,0 @@ -set(fortran_src - gen_schmidt.f90 - hgrid_ak.f90 - pietc.f90 - pkind.f90 - pmat4.f90 - pmat5.f90 - pmat.f90 - psym2.f90 - regional_grid.f90) - -set(exe_name regional_grid) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - NetCDF::NetCDF_Fortran) - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${exec_dir}) diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/gen_schmidt.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/gen_schmidt.f90 deleted file mode 100644 index 68fd2b6e2..000000000 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/gen_schmidt.f90 +++ /dev/null @@ -1,477 +0,0 @@ -!============================================================================= -subroutine get_qqt(nxh,nyh,ncor,j0xy,p,q) -!============================================================================= -! Assume the grid to be mirror-symmetric across both medians, so that the -! computation of the quality diagnostic, Q, need only involve the positive -! quadrant of the grid. The norm associated with the definition of Q is the -! Frobenius norm (Q is the grid-mean of the squared-Frobenius norm of the -! log of the Gram matrix of the given distribution of jacobian matrices.) -!============================================================================= -use pkind, only: dp -use pietc, only: u0,u1,o2 -use pmat4, only: outer_product -use psym2 -implicit none -integer, intent(in ):: nxh,nyh,ncor -real(dp),dimension(3,2,0:nxh,0:nyh),intent(in ):: j0xy -real(dp),dimension(2,2), intent(inout):: p -real(dp), intent( out):: q -!----------------------------------------------------------------------------- -integer,parameter :: nit=5 -real(dp),parameter :: acrit=1.e-8,dpx=.0099 -real(dp),dimension(0:nxh,0:nyh) :: wxy -real(dp),dimension(3,2) :: j0,j -real(dp),dimension(2,2) :: el,pf,elp,elmean,g,ppx,pmx,ppy,pmy -real(dp),dimension(2) :: hess,grad -real(dp) :: anorm,q00,qpx,qmx,qpy,qmy,c,w -integer :: ix,iy,lx,ly,it -!============================================================================= -call get_wxy(nxh,nyh,ncor,wxy)! <- get 2D extended trapezoidal averaging wts -if(p(1,1)==u0)then; p=0; p(1,1)=u1; p(2,2)=u1; endif -! Iteratively calibrate preconditioner, p, to make elmean vanish: -anorm=1 -do it=1,nit - elmean=0 - q=0 - do iy=0,nyh; do ix=0,nxh - j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) -! Precondition the Jacobian using latest iteration of P: - j=matmul(j0,p) -! Find the Gram matrix, G, implied by the column vectors of the new J: - g=matmul(transpose(j),j) -! Find the matrix logarithm, L = log(G), contrinutions to elmean and q: - call logsym2(g,el); el=el/2; elmean=elmean+w*el; q=q+w*sum(el**2) - enddo ; enddo - if(anormnit)then - print'("WARNING: In get_qqt, apparent failure of iteration to converge")' - read(*,*) -endif - -q00=q -ppx=p; ppx(1,1)=ppx(1,1)*(1+dpx);qpx=0 -pmx=p; pmx(1,1)=pmx(1,1)*(1-dpx);qmx=0 -ppy=p; ppy(2,2)=ppy(2,2)*(1+dpx);qpy=0 -pmy=p; pmy(2,2)=pmy(2,2)*(1-dpx);qmy=0 -do iy=0,nyh; do ix=0,nxh - j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) - j=matmul(j0,ppx); g=matmul(transpose(j),j) - call logsym2(g,el); el=el/2; qpx=qpx+w*sum(el**2) - j=matmul(j0,pmx); g=matmul(transpose(j),j) - call logsym2(g,el); el=el/2; qmx=qmx+w*sum(el**2) - j=matmul(j0,ppy); g=matmul(transpose(j),j) - call logsym2(g,el); el=el/2; qpy=qpy+w*sum(el**2) - j=matmul(j0,pmy); g=matmul(transpose(j),j) - call logsym2(g,el); el=el/2; qmy=qmy+w*sum(el**2) -enddo; enddo -! Estimate a (diagonal) Hessian matrix and a gradient vector: -hess=(/ (qpx-2*q00+qmx)/dpx**2, (qpy-2*q00+qmy)/dpx**2 /) -grad=(/ (qpx-qmx)/(2*dpx) , (qpy-qmy)/(2*dpx) /) - -!!print'('' hessian components:'',t30,2(1x,e20.14))',hess !!!!!!! -!!print'('' grad components:'',t30,2(1x,e20.14))',grad !!!!!!! -! If the hessian is positive, polish the final p with a final Newton iteration: -if(hess(1)>0 .and. hess(2)>0.)then - c=u1-grad(1)/hess(1); p(:,1)=p(:,1)*c - c=u1-grad(2)/hess(2); p(:,2)=p(:,2)*c -endif - -! and calculate the new q. Keep it only if is numerically smaller than before: -q00=0 -do iy=0,nyh; do ix=0,nxh - j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) - j=matmul(j0,p); g=matmul(transpose(j),j) - call logsym2(g,el); el=el/2; q00=q00+w*sum(el**2) -enddo; enddo -!!print'('' adjusted final q: '',e20.14)',q00 -if(q00nit)then - print'("WARNING: In get_qqt, apparent failure of iteration to converge")' - read(*,*) -endif - -q00=q -ppx=p; ppx(1,1)=ppx(1,1)*(1+dpx);qpx=0 -pmx=p; pmx(1,1)=pmx(1,1)*(1-dpx);qmx=0 -ppy=p; ppy(2,2)=ppy(2,2)*(1+dpx);qpy=0 -pmy=p; pmy(2,2)=pmy(2,2)*(1-dpx);qmy=0 -do iy=0,nyh; do ix=0,nxh - j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) - j=matmul(j0,ppx); g=matmul(transpose(j),j) - call logsym2(g,el);el=el/2;qpx=qpx+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) - j=matmul(j0,pmx); g=matmul(transpose(j),j) - call logsym2(g,el);el=el/2;qmx=qmx+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) - j=matmul(j0,ppy); g=matmul(transpose(j),j) - call logsym2(g,el);el=el/2;qpy=qpy+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) - j=matmul(j0,pmy); g=matmul(transpose(j),j) - call logsym2(g,el);el=el/2;qmy=qmy+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) -enddo; enddo -! Estimate a (diagonal) Hessian matrix and a gradient vector: -hess=(/ (qpx-2*q00+qmx)/dpx**2, (qpy-2*q00+qmy)/dpx**2 /) -hess=(/8.,8./) -grad=(/ (qpx-qmx)/(2*dpx) , (qpy-qmy)/(2*dpx) /) -! If the hessian is positive, polish p with a final Newton iteration: -if(hess(1)>0 .and. hess(2)>0.)then - c=u1-grad(1)/hess(1); p(:,1)=p(:,1)*c - c=u1-grad(2)/hess(2); p(:,2)=p(:,2)*c -endif - -! and calculate the new q. Keep it only if it's numerically smaller than before: -q00=0 -do iy=0,nyh; do ix=0,nxh - j0=j0xy(:,:,ix,iy); w=wxy(ix,iy) - j=matmul(j0,p); g=matmul(transpose(j),j) - call logsym2(g,el);el=el/2;q00=q00+w*(twc*sum(el**2)+tw*(el(1,1)+el(2,2))**2) -enddo; enddo -if(q004)stop 'In get_wxy; ncor is out of bounds' -if(ncor>=min(nxh,nyh))stop 'In get_wxy; ncor is too large for this small grid' -! the wx and wy are the weight coefficients for an unnormalized -! extended trapezoidal integration. The end correction coefficients can -! be found by staggering, then summing, the Adams-Moulton coefficients -! at both ends. -wx=u1; wx(0)=o2; wx(nxh:nxh-ncor:-1)=cor -wy=u1; wy(0)=o2; wy(nyh:nyh-ncor:-1)=cor -wxy=outer_product(wx,wy); wxy=wxy/sum(wxy) -end subroutine get_wxy - -!============================================================================= -subroutine getedges(arcx,arcy,edgex,edgey) -!============================================================================= -! For angles (degrees) of the arcs spanning the halfwidths between the -! region's center and its x and y edges, get the two cartesian vectors -! that represent the locations of these edge midpoints in the positive x and y -! directions. -!============================================================================= -use pkind, only: dp -use pietc, only: u0,dtor -implicit none -real(dp), intent(in ):: arcx,arcy -real(dp),dimension(3),intent(out):: edgex,edgey -!------------------------------------------------------------------------------ -real(dp):: cx,sx,cy,sy -!============================================================================== -cx=cos(arcx*dtor); sx=sin(arcx*dtor) -cy=cos(arcy*dtor); sy=sin(arcy*dtor) -edgex=(/sx,u0,cx/); edgey=(/u0,sy,cy/) -end subroutine getedges - -!============================================================================== -subroutine xmtoxc_ak(a,kappa,xm,xc,xcd,ff) -!============================================================================== -! Assuming the A-kappa parameterization of the generalized schmidt-transformed -! gnomonic mapping, and given a map-space 2-vector, xm, find the corresponding -! cartesian unit 3-vector and its derivative wrt xm, jacobian matrix, xcd. -! If for any reason the mapping cannot be done, return a raised failure -! flag, FF. -!============================================================================= -use pkind, only: dp -use pietc, only: T,F -implicit none -real(dp), intent(in ):: a,kappa -real(dp),dimension(2), intent(in ):: xm -real(dp),dimension(3), intent(out):: xc -real(dp),dimension(3,2),intent(out):: xcd -logical, intent(out):: ff -!----------------------------------------------------------------------------- -real(dp),dimension(2,2):: xtd,xsd -real(dp),dimension(2) :: xt,xs -!============================================================================= -call xmtoxt(a,xm,xt,xtd,ff); if(ff)return -call xttoxs(kappa,xt,xs,xsd,ff); if(ff)return -xsd=matmul(xsd,xtd) -call xstoxc(xs,xc,xcd) -xcd=matmul(xcd,xsd) -end subroutine xmtoxc_ak - -!============================================================================= -subroutine xctoxm_ak(a,kappa,xc,xm,ff) -!============================================================================= -! Inverse mapping of xmtoxc_ak. That is, go from given cartesian unit 3-vector, -! xc, to map coordinate 2-vector xm (or return a raised failure flag, FF, if -! the attempt fails). -!============================================================================= -use pkind, only: dp -use pietc, only: F,T,u0,u1 -implicit none -real(dp), intent(in ):: a,kappa -real(dp),dimension(3),intent(in ):: xc -real(dp),dimension(2),intent(out):: xm -logical, intent(out):: ff -!----------------------------------------------------------------------------- -real(dp),dimension(2):: xs,xt -!============================================================================= -ff=F -call xctoxs(xc,xs) -call xstoxt(kappa,xs,xt,ff); if(ff)return -call xttoxm(a,xt,xm,ff) -end subroutine xctoxm_ak - -!============================================================================== -subroutine zmtozt(a,zm,zt,ztd,ff) -!============================================================================== -! Evaluate the function, zt = tan(sqrt(A)*z)/sqrt(A), and its deivative, ztd, -! for positive and negative A and for the limiting case, A --> 0 -!============================================================================== -use pkind, only: dp -use pietc, only: F,T,u1,pih -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>0)then; ra=sqrt( a); zt=tan (ra*zm)/ra; ff=abs(ra*zm)>=pih -elseif(a<0)then; ra=sqrt(-a); zt=tanh(ra*zm)/ra -else ; zt=zm -endif -ztd=u1+a*zt*zt -end subroutine zmtozt - -!============================================================================= -subroutine zttozm(a,zt,zm,ff) -!============================================================================= -! Inverse of zmtozt -!============================================================================= -use pkind, only: dp -use pietc, only: F,u1 -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>0)then; ra=sqrt( a); razt=ra*zt; zm=atan (razt)/ra -elseif(a<0)then; ra=sqrt(-a); razt=ra*zt; ff=abs(razt)>=u1; if(ff)return - zm=atanh(razt)/ra -else ; zm=zt -endif -end subroutine zttozm - -!============================================================================== -subroutine xmtoxt(a,xm,xt,xtd,ff) -!============================================================================== -! Like zmtozt, but for 2-vector xm and xt, and 2*2 diagonal Jacobian xtd -!============================================================================== -use pkind, only: dp -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:: i -!============================================================================== -xtd=0; do i=1,2; call zmtozt(a,xm(i),xt(i),xtd(i,i),ff); if(ff)return; enddo -end subroutine xmtoxt - -!============================================================================= -subroutine xttoxm(a,xt,xm,ff) -!============================================================================= -! Inverse of xmtoxt -!============================================================================ -use pkind, only: dp -use pietc, only: F -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:: i -!============================================================================= -do i=1,2; call zttozm(a,xt(i),xm(i),ff); if(ff)return; enddo -end subroutine xttoxm - -!============================================================================== -subroutine xttoxs(kappa,xt,xs,xsd,ff) -!============================================================================== -! Scaled gnomonic plane xt to standard stereographic plane xs -!============================================================================== -use pkind, only: dp -use pietc, only: u0,u1 -implicit none -real(dp), intent(in ):: kappa -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):: s,sp,rsp,rspp,rspps,rspdx,rspdy -!============================================================================== -s=kappa*(xt(1)*xt(1) + xt(2)*xt(2)); sp=u1+s -ff=(sp<=u0); if(ff)return -rsp=sqrt(sp) -rspp=u1+rsp -rspps=rspp**2 -xs=xt/rspp -rspdx=kappa*xt(1)/rsp -rspdy=kappa*xt(2)/rsp -xsd(1,1)=u1/rspp -xt(1)*rspdx/rspps -xsd(1,2)= -xt(1)*rspdy/rspps -xsd(2,1)= -xt(2)*rspdx/rspps -xsd(2,2)=u1/rspp -xt(2)*rspdy/rspps -end subroutine xttoxs - -!============================================================================= -subroutine xstoxt(kappa,xs,xt,ff) -!============================================================================= -! Inverse of xttoxs. -!============================================================================= -use pkind, only: dp -use pietc, only: u1 -implicit none -real(dp), intent(in ):: kappa -real(dp),dimension(2),intent(in ):: xs -real(dp),dimension(2),intent(out):: xt -logical, intent(out):: ff -!----------------------------------------------------------------------------- -real(dp):: s,sc -!============================================================================= -s=kappa*(xs(1)*xs(1)+xs(2)*xs(2)); sc=u1-s -ff=(sc<=0); if(ff)return -xt=2*xs/sc -end subroutine xstoxt - -!============================================================================= -subroutine xstoxc(xs,xc,xcd) -!============================================================================= -! 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 -!============================================================================= -use pkind, only: dp -use pietc, only: u1,u2 -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 xctoxs(xc,xs) -!============================================================================= -! Inverse of xstoxc. I.e., cartesians to stereographic -!============================================================================= -use pkind, only: dp -use pietc, only: u1 -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 diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 deleted file mode 100644 index 4848c4be6..000000000 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/hgrid_ak.f90 +++ /dev/null @@ -1,206 +0,0 @@ -!============================================================================= -subroutine hgrid_ak(lx,ly,nx,ny,a,k,plat,plon,pazi, & - re,delx,dely, glat,glon,garea,dx,dy,angle_dx,angle_dy, ff) -!============================================================================= -! Use a and k as the parameters of a generalized Schmidt-transformed -! gnomonic mapping centered at (plat,plon) and twisted about this center -! by an azimuth angle of pazi counterclockwise (these angles in radians). -! -! Assuming the radius of the earth is re, and using the central mapping -! point as the coordinate origin, set up the grid with central x-spacing delx -! and y-spacing dely in physical units, 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, 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 -! in the SQUARE of the same physical length unit that was employed to define -! the radius of the earth, re, and the central grid steps, delx and dely. -! 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 snd 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 degrees 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 pkind, only: dp -use pietc, only: u0,u1,dtor,rtod -use pmat4, only: cross_product,triple_product -use pmat5, only: ctog -implicit none -integer, intent(in ):: lx,ly,nx,ny -real(dp), intent(in ):: a,k,plat,plon,pazi, & - re,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,& - rlat,drlata,drlatb,drlatc, & - rlon,drlona,drlonb,drlonc, delxy,delxore,delyore -integer :: ix,iy,mx,my,lxm,lym,mxp,myp -!============================================================================= -delxore=delx/re -delyore=dely/re -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*delyore - do ix=lx,mx - xm(1)=ix*delxore - call xmtoxc_ak(a,k,xm,xc,xcd,ff); if(ff)return - xcd=matmul(prot,xcd) - xc =matmul(prot,xc ) - call ctog(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))*rtod - angle_dy(ix,iy)=atan2(-xcd2(1,2),xcd2(2,2))*rtod - 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*delxore -do iy=ly,my - xm(2)=iy*delyore - 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*delxore -do iy=ly,my - xm(2)=iy*delyore - 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*delyore -do ix=lx,mx - xm(1)=ix*delxore - 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*delyore -do ix=lx,mx - xm(1)=ix*delxore - 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*delyore -!-- extra bottom left corner: -xm(1)=lxm*delxore -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*delxore -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*delyore -!-- extra top left corner: -xm(1)=lxm*delxore -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*delxore -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*(dxt(lx :mx-1,:)+dxt(lx+1:mx ,:)) & - -(dxt(lxm:mx-2,:)+dxt(lx+2:mxp,:)))/24 -dy =(13*(dyt(:,ly :my-1)+dyt(:,ly+1:my )) & - -(dyt(:,lym:my-2)+dyt(:,ly+2:myp)))/24 -gat(lx:mx-1,:)=(13*(gat(lx :mx-1,:)+gat(lx+1:mx ,:)) & - -(gat(lxm:mx-2,:)+gat(lx+2:mxp,:)))/24 -garea =(13*(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 -! Convert degrees to radians in the glat and glon arrays: -glat=glat*dtor -glon=glon*dtor - -end subroutine hgrid_ak diff --git a/sorc/fre-nctools.fd/tools/regional_grid.fd/pietc.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/pietc.f90 deleted file mode 100644 index f6abe1af3..000000000 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/pietc.f90 +++ /dev/null @@ -1,95 +0,0 @@ -! -!============================================================================= -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,u1=1,mu1=-u1,u2=2,mu2=-u2,u3=3,mu3=-u3,u4=4,mu4=-u4,u5=5,mu5=-u5, & - u6=6,mu6=-u6,o2=u1/2,o3=u1/3,o4=u1/4,o5=u1/5,o6=u1/6, & - 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/sorc/fre-nctools.fd/tools/regional_grid.fd/pkind.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/pkind.f90 deleted file mode 100644 index abc5841b7..000000000 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/pkind.f90 +++ /dev/null @@ -1,8 +0,0 @@ -module pkind -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/sorc/fre-nctools.fd/tools/regional_grid.fd/pmat.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/pmat.f90 deleted file mode 100644 index 11f1b0f7b..000000000 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/pmat.f90 +++ /dev/null @@ -1,1082 +0,0 @@ -! -! ********************************************** -! * MODULE pmat * -! * R. J. Purser, NOAA/NCEP/EMC 1993 * -! * and Tsukasa Fujita, visiting scientist * -! * from JMA. * -! * Major modifications: 2002, 2009, 2012 * -! * jim.purser@noaa.gov * -! * * -! ********************************************** -! -! 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: 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) -!---------------- -real(sp),dimension(:,:),intent(inout):: a -logical, intent( out):: ff -integer :: m,i,j,jp,l -real(sp) :: d -integer,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)=1./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 :: m,i,j,jp,l -real(DP) :: d -integer, 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/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] -!============================================================================= -complex(dpc),dimension(:,:),intent(INOUT):: a -logical, intent( OUT):: ff -integer :: m,i,j,jp,l -complex(dpc) :: d -integer, 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)=1/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,dimension(size(a,1)) :: ipiv -integer :: 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, dimension(size(a,1)) :: ipiv -integer :: 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, dimension(size(a,1)) :: ipiv -integer :: 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,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, 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,dimension(:,:),intent(INOUT):: imat -logical, intent( OUT):: ff -!----------------------------------------------------------------------------- -real(dp),parameter :: eps=1.e-10_dp -real(dp),dimension(size(imat,1),size(imat,1)):: dmat -integer :: 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, 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, 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, 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. -!============================================================================= -real(SP),intent(INOUT) :: a(:,:) -real(SP),intent(OUT ) :: d -integer, intent(OUT ) :: ipiv(:) -logical, intent(OUT ) :: ff -integer :: 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=0 - do j=1,m - aa=abs(a(i,j)) - if(aa > aam)aam=aa - enddo - if(aam == 0)then - print '("In sldumf; row ",i6," of matrix vanishes")',i - ff=t - return - endif - s(i)=1/aam -enddo -d=1. -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 == 0)then - jm=j-1 - print '(" failure in sldumf:"/" matrix singular, rank=",i3)',jm - ff=t - return - endif - ajji=1/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] -!============================================================================= -real(DP), intent(INOUT) :: a(:,:) -real(DP), intent(OUT ) :: d -integer, intent(OUT ) :: ipiv(:) -logical, intent(OUT ) :: ff -integer :: 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=0 - do j=1,m - aa=abs(a(i,j)) - if(aa > aam)aam=aa - enddo - if(aam == 0)then - print '("In dldumf; row ",i6," of matrix vanishes")',i - ff=t - return - endif - s(i)=1/aam -enddo -d=1. -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 == 0)then - jm=j-1 - print '(" Failure in dldumf:"/" matrix singular, rank=",i3)',jm - ff=t - return - endif - ajji=1/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: c0 -complex(dpc), intent(INOUT) :: a(:,:) -complex(dpc), intent(OUT ) :: d -integer, intent(OUT ) :: ipiv(:) -logical, intent(OUT ) :: ff -integer :: 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=0 - do j=1,m - aa=abs(a(i,j)) - if(aa > aam)aam=aa - enddo - if(aam == 0)then - print '("In cldumf; row ",i6," of matrix vanishes")',i - ff=t - return - endif - s(i)=1/aam -enddo -d=1. -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=1/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 -!============================================================================= -integer, dimension(:), intent(in) :: ipiv -real(sp),dimension(:,:),intent(in) :: a -real(sp),dimension(:,:),intent(inout) :: b -integer :: 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=1/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] -!============================================================================= -integer, dimension(:), intent(in ) :: ipiv -real(dp), dimension(:,:),intent(in ) :: a -real(dp), dimension(:,:),intent(inout) :: b -integer :: 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=1/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] -!============================================================================= -integer, dimension(:), intent(in ) :: ipiv -complex(dpc),dimension(:,:),intent(in ) :: a -complex(dpc),dimension(:,:),intent(inout) :: b -integer :: 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=1/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 -!============================================================================= -integer, dimension(:), intent(in) :: ipiv -real(sp),dimension(:,:),intent(in) :: a -real(sp),dimension(:), intent(inout) :: b -integer :: 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=1/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] -!============================================================================= -integer, dimension(:), intent(in ) :: ipiv(:) -real(dp), dimension(:,:),intent(in ) :: a(:,:) -real(dp), dimension(:), intent(inout) :: b(:) -integer :: 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=1/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] -!============================================================================= -integer, dimension(:), intent(in ) :: ipiv(:) -complex(dpc),dimension(:,:),intent(in ) :: a(:,:) -complex(dpc),dimension(:), intent(inout) :: b(:) -integer :: 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=1/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) -!============================================================================= -real(sp), intent(IN ) :: a(:,:) -real(sp), intent(INOUT) :: b(:,:) -logical :: ff -!----------------------------------------------------------------------------- -integer :: 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 <= 0) - if(ff)then - print '("sL1Lmf detects nonpositive a, rank=",i6)',jm - return - endif - b(j,j)=sqrt(s) - bjji=1/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) = 0 -enddo -end subroutine sl1lmf -!============================================================================= -subroutine dl1lmf(a,b,ff) ! [L1Lm] -!============================================================================= -real(dp), intent(IN ) :: a(:,:) -real(dp), intent(INOUT) :: b(:,:) -logical :: ff -!----------------------------------------------------------------------------- -integer :: 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 <= 0) - if(ff)then - print '("dL1LMF detects nonpositive A, rank=",i6)',jm - return - endif - b(j,j)=sqrt(s) - bjji=1/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) = 0 -enddo -return -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 -!============================================================================= -real(sp), intent(IN ):: a(:,:) -real(sp), intent(INOUT):: b(:,:) -real(sp), intent( OUT):: d(:) -logical, intent( OUT):: ff -!----------------------------------------------------------------------------- -integer :: 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) = 1 - ff=(d(j) == 0) - if(ff)then - print '("In sldlmf; singularity of matrix detected")' - print '("Rank of matrix: ",i6)',jm - return - endif - bjji=1/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)=0 -enddo -end subroutine sldlmf -!============================================================================= -subroutine dldlmf(a,b,d,ff) ! [LDLM] -!============================================================================= -! Modified Cholesky Q --> L*D*U, U(i,j)=L(j,i) -!============================================================================= -real(dp), intent(IN ) :: a(:,:) -real(dp), intent(INOUT) :: b(:,:) -real(dp), intent( OUT) :: d(:) -logical, intent( OUT) :: ff -!----------------------------------------------------------------------------- -integer :: 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) == 0) - if(ff)then - print '("In dldlmf; singularity of matrix detected")' - print '("Rank of matrix: ",i6)',jm - return - endif - bjji=1/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)=0 -enddo -end subroutine dldlmf - -!============================================================================== -subroutine sinvu(a)! [invu] -!============================================================================== -! Invert the upper triangular matrix in place by transposing, calling -! invl, and transposing again. -!============================================================================== -real,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 -!============================================================================== -real(sp), intent(inout) :: a(:,:) -integer :: m,j, i -m=size(a,1) -do j=m,1,-1 - a(1:j-1,j) = 0.0 - a(j,j)=1./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] -!============================================================================== -real(dp), intent(inout) :: a(:,:) -integer :: m,j, i -m=size(a,1) -do j=m,1,-1 - a(1:j-1,j) = 0.0 - a(j,j)=1./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, intent(in ) :: a(:,:) -real, intent(inout) :: u(:) -integer :: 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 :: 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, intent(in ) :: a(:,:) -real, intent(inout) :: u(:) -integer :: 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 :: 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/sorc/fre-nctools.fd/tools/regional_grid.fd/pmat4.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/pmat4.f90 deleted file mode 100644 index 8cb2fcb70..000000000 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/pmat4.f90 +++ /dev/null @@ -1,1924 +0,0 @@ -! -! ********************************************** -! * MODULE pmat4 * -! * R. J. Purser, NOAA/NCEP/EMC Oct 2005 * -! * 18th May 2012 * -! * jim.purser@noaa.gov * -! * * -! ********************************************** -! -! 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: 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; 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] -!============================================================================= -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] -!============================================================================= -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] -!============================================================================= -real(sp),dimension(:),intent(IN):: a -real(sp),dimension(size(a)) :: b -real(sp) :: s -s=absv_s(a); if(s==0)then; b=0;else;b=a/s;endif -end function normalized_s -!============================================================================= -function normalized_d(a)result(b)! [normalized] -!============================================================================= -real(dp),dimension(:),intent(IN):: a -real(dp),dimension(size(a)) :: b -real(dp) :: s -s=absv_d(a); if(s==0)then; b=0;else;b=a/s;endif -end function normalized_d - -!============================================================================= -function orthogonalized_s(u,a)result(b)! [orthogonalized] -!============================================================================= -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] -!============================================================================= -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] -!============================================================================= -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] -!============================================================================= -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 outer_product_s(a,b)result(c)! [outer_product] -!============================================================================= -real(sp),dimension(:), intent(in ):: a -real(sp),dimension(:), intent(in ):: b -real(sp),DIMENSION(size(a),size(b)):: c -integer :: 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] -!============================================================================= -real(dp),dimension(:), intent(in ):: a -real(dp),dimension(:), intent(in ):: b -real(dp),dimension(size(a),size(b)):: c -integer :: 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] -!============================================================================= -integer,dimension(:), intent(in ):: a -integer,dimension(:), intent(in ):: b -integer,dimension(size(a),size(b)):: c -integer :: 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] -!============================================================================= -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] -!============================================================================= -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] -!============================================================================= -real(sp),dimension(:,:),intent(IN ) ::a -real(sp) :: det -real(sp),dimension(size(a,1),size(a,1)):: b -integer :: 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(nranknrank)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)<0)s=-s - det=det*s - 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 gram_s - -!============================================================================= -subroutine gram_d(as,b,nrank,det)! [gram] -!============================================================================= -real(dp),dimension(:,:),intent(IN ) :: as -real(dp),dimension(:,:),intent(OUT) :: b -integer, intent(OUT) :: nrank -real(dp), intent(OUT) :: det -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -real(dp),parameter :: crit=1.e-9_dp -real(dp),dimension(size(as,1),size(as,2)):: a -real(dp),dimension(size(as,2),size(as,1)):: ab -real(dp),dimension(size(as,1)) :: tv,w -real(dp) :: val,s,vcrit -integer :: i,j,k,l,m,n -integer,dimension(2) :: ii -!============================================================================= -n=size(as,1) -m=size(as,2) -if(n/=size(b,1) .or. n/=size(b,2))stop 'In gram; incompatible dimensions' -a=as -b=identity(n) -det=1 -val=maxval(abs(a)) -if(val==0)then - nrank=0 - return -endif -vcrit=val*crit -nrank=min(n,m) -do k=1,n - if(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)<0)s=-s - det=det*s - 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 gram_d - -!============================================================================= -subroutine graml_d(as,b,nrank,detsign,ldet)! [gram] -!============================================================================= -! A version of gram_d where the determinant information is returned in -! logarithmic form (to avoid overflows for large matrices). When the -! matrix is singular, the "sign" of the determinant, detsign, is returned -! as zero (instead of either +1 or -1) and ldet is then just the log of -! the nonzero factors found by the process. -!============================================================================= -real(dp),dimension(:,:),intent(IN ) :: as -real(dp),dimension(:,:),intent(OUT) :: b -integer, intent(OUT) :: nrank -integer, intent(out) :: detsign -real(dp), intent(OUT) :: ldet -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -real(dp),parameter :: crit=1.e-9_dp -real(dp),dimension(size(as,1),size(as,2)):: a -real(dp),dimension(size(as,2),size(as,1)):: ab -real(dp),dimension(size(as,1)) :: tv,w -real(dp) :: val,s,vcrit -integer :: i,j,k,l,m,n -integer,dimension(2) :: ii -!============================================================================= -detsign=1 -n=size(as,1) -m=size(as,2) -if(n/=size(b,1) .or. n/=size(b,2))stop 'In gram; incompatible dimensions' -a=as -b=identity(n) -!det=1 -ldet=0 -val=maxval(abs(a)) -if(val==0)then - nrank=0 - return -endif -vcrit=val*crit -nrank=min(n,m) -do k=1,n - if(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)<0)s=-s - if(s<0)then - ldet=ldet+log(-s) - detsign=-detsign - elseif(s>0)then - ldet=ldet+log(s) - else - detsign=0 - endif - -! det=det*s - 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. -real(sp),dimension(:,:),intent(INOUT) :: b -integer, intent( OUT) :: nrank -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -real(sp),parameter :: crit=1.e-5_sp -real(sp) :: val,vcrit -integer :: 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=0 - return -endif -vcrit=val*crit -do k=1,n - val=sqrt(dot_product(b(:,k),b(:,k))) - if(val<=vcrit)then - b(:,k:n)=0 - 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. -real(dp),dimension(:,:),intent(INOUT) :: b -integer, intent( OUT) :: nrank -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -real(dp),parameter :: crit=1.e-9_dp -real(dp) :: val,vcrit -integer :: 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=0 - return -endif -vcrit=val*crit -do k=1,n - val=sqrt(dot_product(b(:,k),b(:,k))) - if(val<=vcrit)then - b(:,k:n)=0 - 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=0 -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=0 - 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(maxpu1(2))then - j=3 -else - j=2 -endif -ss=u1(j) -if(ss==0)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/2 - -! 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 -!============================================================================== -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 -!============================================================================= -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 -!============================================================================= -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] -!============================================================================= -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 -!============================================================================= -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: u1,u2,o2 -integer, 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,parameter :: L=5 -real(dp),dimension(n,n):: c,p -real(dp) :: t -integer :: i,m -!============================================================================= -m=10+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*2+matmul(b,b) -enddo -do i=1,n - b(i,i)=b(i,i)+1 -enddo -detb=0; 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: u1,u2,o2 -integer, 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,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 :: i,j,k,m,n1 -!============================================================================= -n1=(n*(n+1))/2 -m=10+log(u1+maxval(abs(a)))/log(u2) -t=o2**m -c=a*t -p=c -pd=0 -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*2+matmul(b,b) -enddo -do i=1,n - b(i,i)=b(i,i)+1 -enddo -detb=0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) -detbd=0; 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: u1,u2,o2 -integer, 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,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 :: i,j,k,ki,kj,m,n1 -!============================================================================= -n1=(n*(n+1))/2 -m=10+log(u1+maxval(abs(a)))/log(u2) -t=o2**m -c=a*t -p=c -pd=0 -pdd=0 -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=0 -b=p -bd=pd -bdd=0 - -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)=2*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*2+matmul(b,b) -enddo -do i=1,n - b(i,i)=b(i,i)+1 -enddo -detb=0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) -detbd=0; do k=1,n; detbd(k)=detb; enddo -detbdd=0; do ki=1,n; do kj=1,n; detbdd(ki,kj)=detb; enddo; enddo -end subroutine expmatdd - -!============================================================================= -subroutine zntay(n,z,zn)! [zntay] -!============================================================================= -integer, intent(IN ):: n -real(dp),intent(IN ):: z -real(dp),intent(OUT):: zn -!----------------------------------------------------------------------------- -integer,parameter :: ni=100 -real(dp),parameter :: eps0=1.e-16 -integer :: i,i2,n2 -real(dp) :: t,eps,z2 -!============================================================================= -z2=z*2 -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)0)then - zn=cosh(rz2) - znd=sinh(rz2)/rz2 - zndd=(zn-znd)/z2 - znddd=(znd-3*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-3*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] -!============================================================================= -real(dp),dimension(3),intent(IN ):: v -complex(dpc), intent(OUT):: z -logical, intent(OUT):: infz -!----------------------------------------------------------------------------- -real(dp),parameter:: zero=0,one=1 -real(dp) :: rr,zzpi -!============================================================================= -infz=.false. -z=cmplx(v(1),v(2),dpc) -if(v(3)>0)then - zzpi=one/(one+v(3)) -else - rr=v(1)**2+v(2)**2 - infz=(rr==zero); if(infz)return ! <- The point is mapped to infinity (90S) - zzpi=(one-v(3))/rr -endif -z=z*zzpi -end subroutine ctoz - -!============================================================================= -subroutine ztoc(z,infz, v)! [ztoc] -!============================================================================= -complex(dpc), intent(IN ):: z -logical, intent(IN ):: infz -real(dp),dimension(3),intent(OUT):: v -!----------------------------------------------------------------------------- -real(dp),parameter:: zero=0,one=1 -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)=2*rsbi*r -v(2)=2*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!!! -!============================================================================= -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,one=1 -real(dp) :: r,q,rs,rsc,rsbi,rsbis -real(dp),dimension(3):: u1,u2 -integer :: 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)=2*rsbi*r -v(2)=2*rsbi*q -v(3)=rsc*rsbi -u1(1)=2*(one+q*q-r*r)*rsbis -u1(2)=-4*r*q*rsbis -u1(3)=-4*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). -!============================================================================ -real(dp),dimension(3),intent(IN ):: xc0,xc1,xc2 -complex(dpc), intent(OUT):: aa,bb,cc,dd -!---------------------------------------------------------------------------- -real(dp),parameter:: zero=0,one=1 -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) XE three cartesian components. -! <-- DLAT degrees latitude -! <-- DLON degrees longitude -!============================================================================= -use pietc, only: u0,rtod -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 -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, only: dtor -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 -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] -!============================================================================= -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: dtor -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)=0 ; dxedlon=dxedlon*dtor -end subroutine dgtocd -!============================================================================= -subroutine sgtocdd(dlat,dlon,xe,dxedlat,dxedlon, & - ddxedlatdlat,ddxedlatdlon,ddxedlondlon)! [gtoc] -!============================================================================= -use pietc, only: dtor -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: dtor -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)=0 ; dxedlon=dxedlon*dtor -ddxedlatdlat(1)=-cla*clo -ddxedlatdlat(2)=-cla*slo -ddxedlatdlat(3)=-sla -ddxedlatdlon(1)= sla*slo -ddxedlatdlon(2)=-sla*clo -ddxedlatdlon(3)= 0 -ddxedlondlon(1)=-cla*clo -ddxedlondlon(2)=-cla*slo -ddxedlondlon(3)= 0 -ddxedlatdlat=ddxedlatdlat*dtor**2 -ddxedlatdlon=ddxedlatdlon*dtor**2 -ddxedlondlon=ddxedlondlon*dtor**2 -end subroutine dgtocdd - -!============================================================================== -subroutine sgtoframem(splat,splon,sorth)! [gtoframe] -!============================================================================== -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. -!============================================================================== -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] -!============================================================================== -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 -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] -!============================================================================== -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 -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] -!============================================================================== -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. -!============================================================================== -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 -!============================================================================= -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+1 -b=s-1 -ab2=a*b*2 -aa=a*a -bb=b*b -aapbb=aa+bb -aambb=aa-bb -d=aapbb-ab2*z -e=aapbb*z-ab2 -di=1/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. -!============================================================================= -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+1 -b=s-1 -ab2=a*b*2 -aa=a*a -bb=b*b -aapbb=aa+bb -aambb=aa-bb -d=aapbb-ab2*z -e=aapbb*z-ab2 -di=1/d -xc2(1)=(aambb*x)*di -xc2(2)=(aambb*y)*di -xc2(3)=e*di -ddi=di*di - -dxc2=0 -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. -!============================================================================= -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+1 -b=s-1 -ab2=a*b*2 -aa=a*a -bb=b*b -aapbb=aa+bb -aambb=aa-bb -d=aapbb-ab2*z -e=aapbb*z-ab2 -di=1/d -xc2(1)=(aambb*x)*di -xc2(2)=(aambb*y)*di -xc2(3)=e*di -ddi=di*di -dddi=ddi*di - -dxc2=0 -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=0 -ddxc2(1,1,3)=ab2*aambb*ddi -ddxc2(1,3,1)=ddxc2(1,1,3) -ddxc2(1,3,3)=2*ab2**2*aambb*x*dddi -ddxc2(2,2,3)=ab2*aambb*ddi -ddxc2(2,3,2)=ddxc2(2,2,3) -ddxc2(2,3,3)=2*ab2**2*aambb*y*dddi -ddxc2(3,3,3)=2*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 -!============================================================================= -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+1 -b=s-1 -ab2=a*b*2 -aa=a*a -bb=b*b -aapbb=aa+bb -aambb=aa-bb -d=aapbb-ab2*z -e=aapbb*z-ab2 -di=1/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. -!============================================================================= -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+1 -b=s-1 -ab2=a*b*2 -aa=a*a -bb=b*b -aapbb=aa+bb -aambb=aa-bb -d=aapbb-ab2*z -e=aapbb*z-ab2 -di=1/d -xc2(1)=(aambb*x)*di -xc2(2)=(aambb*y)*di -xc2(3)=e*di -ddi=di*di - -dxc2=0 -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. -!============================================================================= -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+1 -b=s-1 -ab2=a*b*2 -aa=a*a -bb=b*b -aapbb=aa+bb -aambb=aa-bb -d=aapbb-ab2*z -e=aapbb*z-ab2 -di=1/d -xc2(1)=(aambb*x)*di -xc2(2)=(aambb*y)*di -xc2(3)=e*di -ddi=di*di -dddi=ddi*di - -dxc2=0 -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=0 -ddxc2(1,1,3)=ab2*aambb*ddi -ddxc2(1,3,1)=ddxc2(1,1,3) -ddxc2(1,3,3)=2*ab2**2*aambb*x*dddi -ddxc2(2,2,3)=ab2*aambb*ddi -ddxc2(2,3,2)=ddxc2(2,2,3) -ddxc2(2,3,3)=2*ab2**2*aambb*y*dddi -ddxc2(3,3,3)=2*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 -!============================================================================= -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 -!============================================================================= -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 -!============================================================================= -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 -!============================================================================= -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 -!============================================================================= -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+1 -b=s-1 -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/sorc/fre-nctools.fd/tools/regional_grid.fd/psym2.f90 b/sorc/fre-nctools.fd/tools/regional_grid.fd/psym2.f90 deleted file mode 100644 index 3b6459047..000000000 --- a/sorc/fre-nctools.fd/tools/regional_grid.fd/psym2.f90 +++ /dev/null @@ -1,498 +0,0 @@ -! *********************************** -! * module psym2 * -! * R. J. Purser * -! * NOAA/NCEP/EMC September 2018 * -! * jim.purser@noaa.gov * -! *********************************** -! -! 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. -! -! DIRECT DEPENDENCIES -! Module: pkind, pietc -! -!============================================================================= -module psym2 -!============================================================================= -use pkind, only: dp -use pietc, only: u0,u1,o2 -implicit none -private -public:: eigensym2,invsym2,sqrtsym2,expsym2,logsym2,id2222 - -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 logsym2d_e; module procedure logsym2d_e; end interface -interface logsym2d_t; module procedure logsym2d_t; end interface -interface id2222; module procedure id2222; 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. -!============================================================================= -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)/2; f=(a-c)/2 -h=sqrt(f**2+b**2) -g=sqrt(b**2+(h+abs(f))**2) -if (g==0)then; vv(:,1)=(/u1,u0/) -elseif(f> 0)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 flagg, 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. -!============================================================================= -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 :: 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). -!============================================================================= -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) -!============================================================================= -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:: 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 -!============================================================================= -real(dp),dimension(2,2),intent(in ):: em -real(dp),dimension(2,2),intent(out):: z -!----------------------------------------------------------------------------- -real(dp),dimension(2,2):: vv,oo -integer :: 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). -!============================================================================= -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)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] -!============================================================================= -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 :: 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=0; 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} -!============================================================================= -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,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 :: i,j,n -!============================================================================= -r=x; r(1,1)=x(1,1)-1; r(2,2)=x(2,2)-1 -z=0; 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)) Date: Wed, 1 Jul 2020 13:18:29 +0000 Subject: [PATCH 24/38] feature/regional_grid This commit references NOAA-EMC#4 Remove computation of global_equiv_resol from the filter topo program. Retain the stand-alone version of global_equiv_resol. Set CRES value for both esg and gfdl regional grids from global_equiv_resol. --- .../tools/filter_topo/filter_topo.F90 | 156 ------------------ ush/fv3gfs_driver_grid.sh | 14 +- ush/fv3gfs_make_grid.sh | 27 ++- 3 files changed, 28 insertions(+), 169 deletions(-) diff --git a/sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 b/sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 index 71a7cd382..ca9f43b53 100644 --- a/sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 +++ b/sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 @@ -63,7 +63,6 @@ program filter_topo !--- compute filter constants for the regional resolution if(regional)then - call global_equiv_resol call compute_filter_constants endif @@ -1764,161 +1763,6 @@ subroutine read_namelist end subroutine read_namelist -!======================================================================= -! Determine the global equivalent resolution for a jim purser -! regional grid. -!======================================================================= - - subroutine global_equiv_resol - - use netcdf - - implicit none - - integer, parameter :: dp = kind(1.0d0) - real(dp), parameter :: pi_geom = 4.0*atan(1.0), & - radius_Earth = 6371000.0 - - character(len=50) :: tile_file - integer :: ncid, nxSG_dimid, nySG_dimid, dASG_varid - integer :: nxSG, nySG, nx, ny, RES_equiv, id_var - real(dp) :: avg_cell_size, min_cell_size, max_cell_size - real(dp), dimension(:,:), allocatable :: & - quarter_dA_ll, quarter_dA_lr, quarter_dA_ur, quarter_dA_ul, & - dASG, dA, sqrt_dA - - WRITE(*,500) - WRITE(*,500) "Compute global equivalent resolution." - WRITE(*,500) "Opening NetCDF mosaic file for reading:" - WRITE(*,500) " file=", trim(grid_file) - -!======================================================================= -! Obtain the grid file name from the mosaic file. -!======================================================================= - - call check( nf90_open(trim(grid_file), NF90_NOWRITE, ncid) ) - - call check( nf90_inq_varid(ncid, 'gridfiles', id_var) ) - - call check ( nf90_get_var(ncid, id_var, tile_file ) ) - - call check ( nf90_close(ncid) ) -! -!======================================================================= -! -! Open the grid file and read in the dimensions of the supergrid. The -! supergrid is a grid that has twice the resolution of the actual/compu- -! tational grid. In the file, the names of the supergrid dimensions are -! nx and ny. Here, however, we reserve those names for the dimensions -! of the actual grid (since in the FV3 code and in other data files, nx -! and ny are used to denote the dimensions of the actual grid) and in- -! stead use the variables nxSG and nySG to denote the dimensions of the -! supergrid. -! -!======================================================================= -! - WRITE(*,500) - WRITE(*,500) "Opening NetCDF grid file for reading:" - WRITE(*,500) " file=", trim(tile_file) - - call check( nf90_open(trim(tile_file), NF90_NOWRITE, ncid) ) - - call check( nf90_inq_dimid(ncid, "nx", nxSG_dimid) ) - call check( nf90_inquire_dimension(ncid, nxSG_dimid, len=nxSG) ) - - call check( nf90_inq_dimid(ncid, "ny", nySG_dimid) ) - call check( nf90_inquire_dimension(ncid, nySG_dimid, len=nySG) ) - - WRITE(*,500) - WRITE(*,500) "Dimensions of supergrid are:" - WRITE(*,520) " nxSG = ", nxSG - WRITE(*,520) " nySG = ", nySG -! -!======================================================================= -! -! Read in the cell areas on the supergrid. Then add the areas of the -! four supergrid cells that make up one grid cell to obtain the cell -! areas on the actual grid. -! -!======================================================================= -! - allocate(dASG(0:nxSG-1, 0:nySG-1)) - call check( nf90_inq_varid(ncid, "area", dASG_varid) ) - call check( nf90_get_var(ncid, dASG_varid, dASG) ) - - call check ( nf90_close(ncid) ) - - nx = nxSG/2 - ny = nySG/2 - - WRITE(*,500) - WRITE(*,500) "Dimensions of (actual, i.e. computational) grid are:" - WRITE(*,520) " nx = ", nx - WRITE(*,520) " ny = ", ny - - allocate(quarter_dA_ll(0:nx-1, 0:ny-1)) - allocate(quarter_dA_lr(0:nx-1, 0:ny-1)) - allocate(quarter_dA_ul(0:nx-1, 0:ny-1)) - allocate(quarter_dA_ur(0:nx-1, 0:ny-1)) - - quarter_dA_ll = dASG(0:nxSG-1:2, 0:nySG-1:2) - quarter_dA_lr = dASG(0:nxSG-1:2, 1:nySG-1:2) - quarter_dA_ur = dASG(1:nxSG-1:2, 1:nySG-1:2) - quarter_dA_ul = dASG(1:nxSG-1:2, 0:nySG-1:2) - - deallocate(dASG) - - allocate(dA(0:nx-1, 0:ny-1)) - allocate(sqrt_dA(0:nx-1, 0:ny-1)) - - dA = quarter_dA_ll + quarter_dA_lr + quarter_dA_ur + quarter_dA_ul - - deallocate(quarter_dA_ll, quarter_dA_lr, quarter_dA_ur, quarter_dA_ul) - -!======================================================================= -! -! Calculate a typical/representative cell size for each cell by taking -! the square root of the area of the cell. Then calculate the minimum, -! maximum, and average cell sizes over the whole grid. -! -!======================================================================= -! - sqrt_dA = sqrt(dA) - deallocate(dA) - min_cell_size = minval(sqrt_dA) - max_cell_size = maxval(sqrt_dA) - avg_cell_size = sum(sqrt_dA)/(nx*ny) - deallocate(sqrt_dA) - - WRITE(*,500) - WRITE(*,500) "Minimum, maximum, and average cell sizes are (based on square" - WRITE(*,500) "root of cell area):" - WRITE(*,530) " min_cell_size = ", min_cell_size - WRITE(*,530) " max_cell_size = ", max_cell_size - WRITE(*,530) " avg_cell_size = ", avg_cell_size -! -!======================================================================= -! -! Use the average cell size to calculate an equivalent global uniform -! cubed-sphere resolution (in units of number of cells) for the regional -! grid. This is the RES that a global uniform (i.e. stretch factor of -! 1) cubed-sphere grid would need to have in order to have the same no- -! minal cell size as the average cell size of the regional grid. -! -!======================================================================= -! - RES_equiv = nint( (2.0*pi_geom*radius_Earth)/(4.0*avg_cell_size) ) - - WRITE(*,500) - WRITE(*,500) "Equivalent global uniform cubed-sphere resolution is:" - WRITE(*,530) " RES_equiv = ", RES_equiv - - 500 FORMAT(A) - 520 FORMAT(A, I7) - 530 FORMAT(A, G) - - end subroutine global_equiv_resol - subroutine check(status) use netcdf integer,intent(in) :: status diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh index 5ec80817e..ac59c088e 100755 --- a/ush/fv3gfs_driver_grid.sh +++ b/ush/fv3gfs_driver_grid.sh @@ -315,10 +315,7 @@ elif [ $gtype = regional ]; then export ntiles=1 tile=7 - rn=$( echo "$stretch_fac * 10" | bc | cut -c1-2 ) - name=C${res}r${rn}n${refine_ratio}_${title} - out_dir=$out_dir/C${res} - mkdir -p $out_dir + name=gfdl grid_dir=$TMPDIR/${name}/grid orog_dir=$TMPDIR/$name/orog filter_dir=$orog_dir # nested grid topography will be filtered online @@ -336,6 +333,13 @@ elif [ $gtype = regional ]; then exit $err fi +# redefine res for gfdl regional grids. + + res=$( ncdump -h ${grid_dir}/C*_grid.tile7.nc | grep -o ":RES_equiv = [0-9]\+" | grep -o "[0-9]" ) + res=${res//$'\n'/} + out_dir=$out_dir/C${res} + mkdir -p $out_dir + echo "Begin regional orography generation at `date`" #---------------------------------------------------------------------------------- @@ -434,7 +438,7 @@ elif [ $gtype = regional_esg ]; then halop1=$(( halo + 1 )) tile=7 - name=regional + name=regional_esg grid_dir=$TMPDIR/${name}/grid orog_dir=$TMPDIR/${name}/orog filter_dir=$TMPDIR/${name}/filter_topo diff --git a/ush/fv3gfs_make_grid.sh b/ush/fv3gfs_make_grid.sh index 02e0dbea6..089d8cecc 100755 --- a/ush/fv3gfs_make_grid.sh +++ b/ush/fv3gfs_make_grid.sh @@ -121,16 +121,21 @@ fi if [ $gtype = regional_esg ]; then $APRUN $exec_dir/global_equiv_resol regional_grid.nc - if [ $? -ne 0 ]; then - set +x - echo - echo "FATAL ERROR running global_equiv_resol." - echo - set -x - exit 2 - fi + +elif [ $gtype = regional ]; then + + $APRUN $exec_dir/global_equiv_resol C${res}_grid.tile7.nc + fi +if [ $? -ne 0 ]; then + set +x + echo + echo "FATAL ERROR running global_equiv_resol." + echo + set -x + exit 2 +fi #--------------------------------------------------------------------------------------- # Create mosaic file. @@ -169,6 +174,12 @@ elif [ $gtype = nest ]; then elif [ $gtype = regional ];then +# For gfdl regional grids, redefine the CRES value. + + res_save=$res + res=$( ncdump -h C${res}_grid.tile7.nc | grep -o ":RES_equiv = [0-9]\+" | grep -o "[0-9]" ) + res=${res//$'\n'/} + mv C${res_save}_grid.tile7.nc C${res}_grid.tile7.nc $APRUN $executable --num_tiles $ntiles --dir $outdir --mosaic C${res}_mosaic --tile_file C${res}_grid.tile7.nc elif [ $gtype = regional_esg ]; then From 84ad5d40327994698a6cf2fa5ea302f815b8b3bf Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 1 Jul 2020 18:28:10 +0000 Subject: [PATCH 25/38] feature/regional_grid This commit references NOAA-EMC#4 Set filtering coefficients for both regional and global grids within filter_topo program. For regional grids, these coefficients are based on the resolution value computed by global_equiv_res. Remove all filtering coefficients from scripts. --- .../tools/filter_topo/filter_topo.F90 | 59 ++++++++----------- ush/fv3gfs_driver_grid.sh | 38 +----------- ush/fv3gfs_filter_topo.sh | 17 +----- 3 files changed, 31 insertions(+), 83 deletions(-) diff --git a/sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 b/sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 index ca9f43b53..156986810 100644 --- a/sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 +++ b/sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 @@ -21,15 +21,14 @@ program filter_topo real, parameter :: tiny_number=1.d-8 - real:: cd4 = 0.16 ! Dimensionless coeff for del-4 difussion (with FCT) - real:: peak_fac = 1.05 ! overshoot factor for the mountain peak - real:: max_slope = 0.15 ! max allowable terrain slope: 1 --> 45 deg - ! 0.15 for C768 or lower; 0.25 C1536; 0.3 for C3072 - integer :: n_del2_weak = 12 + real:: cd4 ! Dimensionless coeff for del-4 difussion (with FCT) + real:: peak_fac ! overshoot factor for the mountain peak + real:: max_slope ! max allowable terrain slope: 1 --> 45 deg + + integer :: n_del2_weak logical :: zs_filter = .true. logical :: zero_ocean = .true. ! if true, no diffusive flux into water/ocean area - integer :: refine_ratio = 1 ! default parent-to-nest space ratio real :: res = 48. ! real value of the 'c' resolution real :: stretch_fac = 1.0 logical :: nested = .false. & @@ -40,8 +39,7 @@ program filter_topo character(len=128) :: mask_field = "slmsk" character(len=128) :: grid_file = "atmos_mosaic.nc" namelist /filter_topo_nml/ topo_file, topo_field, mask_field, grid_file, zero_ocean, & - zs_filter, cd4, n_del2_weak, peak_fac, max_slope, stretch_fac, refine_ratio, res, & - nested, grid_type, regional + zs_filter, stretch_fac, res, nested, grid_type, regional integer :: stdunit = 6 integer :: ntiles = 0 @@ -61,10 +59,8 @@ program filter_topo !--- read namelist call read_namelist() - !--- compute filter constants for the regional resolution - if(regional)then - call compute_filter_constants - endif + !--- compute filter constants according to grid resolution. + call compute_filter_constants !--- read the target grid. call read_grid_file(regional) @@ -1782,52 +1778,49 @@ subroutine compute_filter_constants ! set the given values for various cube resolutions (c48, c96, c192, c384, c768, c1152, c3072) - integer,parameter :: nres=7 + integer,parameter :: nres=8 integer :: index1,index2,n - real :: factor,res_regional - - real,dimension(1:nres) :: cube_res=(/48.,96.,192.,384.,768.,1152.,3072./) + real :: factor - real,dimension(1:nres) :: n_del2_weak_vals=(/4.,8.,12.,12.,16.,20.,24./) - real,dimension(1:nres) :: cd4_vals =(/0.12,0.12,0.15,0.15,0.15,0.15,0.15/) - real,dimension(1:nres) :: max_slope_vals =(/0.12,0.12,0.12,0.12,0.12,0.16,0.30/) - real,dimension(1:nres) :: peak_fac_vals =(/1.1,1.1,1.05,1.0,1.0,1.0,1.0/) - -!------------------------------------------------------------------ -! What is the equivalent cube resolution of this regional domain -! where res is the parent cube's resolution? -!------------------------------------------------------------------ + real,dimension(1:nres) :: cube_res=(/48.,96.,128.,192.,384.,768.,1152.,3072./) - res_regional=res*stretch_fac*real(refine_ratio) + real,dimension(1:nres) :: n_del2_weak_vals=(/4.,8.,8.,12.,12.,16.,20.,24./) + real,dimension(1:nres) :: cd4_vals =(/0.12,0.12,0.13,0.15,0.15,0.15,0.15,0.15/) + real,dimension(1:nres) :: max_slope_vals =(/0.12,0.12,0.12,0.12,0.12,0.12,0.16,0.30/) + real,dimension(1:nres) :: peak_fac_vals =(/1.1,1.1,1.1,1.05,1.0,1.0,1.0,1.0/) - if(res_regionalcube_res(nres))then + elseif(res>cube_res(nres))then index1 = nres index2 = nres factor = 0. else do n=2,nres - if(res_regional<=cube_res(n))then + if(res<=cube_res(n))then index2 = n index1 = n-1 - factor = (res_regional-cube_res(n-1))/(cube_res(n)-cube_res(n-1)) + factor = (res-cube_res(n-1))/(cube_res(n)-cube_res(n-1)) exit endif enddo endif - print* - print*,'global cres equival, toms method ',res_regional - n_del2_weak = nint(n_del2_weak_vals(index1)+factor*(n_del2_weak_vals(index2)-n_del2_weak_vals(index1))) cd4 = cd4_vals(index1)+factor*(cd4_vals(index2)-cd4_vals(index1)) max_slope = max_slope_vals(index1)+factor*(max_slope_vals(index2)-max_slope_vals(index1)) peak_fac = peak_fac_vals(index1)+factor*(peak_fac_vals(index2)-peak_fac_vals(index1)) + print*,'' + print*,'- FILTER COEFFICIENTS FOR RESOLUTION ', res + print*,'- CD4: ', cd4 + print*,'- N_DEL2_WEAK: ', n_del2_weak + print*,'- MAX_SLOPE: ', max_slope + print*,'- PEAK_FAC: ', peak_fac + end subroutine compute_filter_constants end program filter_topo diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh index ac59c088e..fee8c1d1e 100755 --- a/ush/fv3gfs_driver_grid.sh +++ b/ush/fv3gfs_driver_grid.sh @@ -97,38 +97,6 @@ rm -fr $TMPDIR mkdir -p $TMPDIR cd $TMPDIR ||exit 8 -#---------------------------------------------------------------------------------------- -# filter_topo parameters. C192->50km, C384->25km, C768->13km, C1152->8.5km, C3072->3.2km -#---------------------------------------------------------------------------------------- - -if [ $res -eq 48 ]; then - cd4=0.12; max_slope=0.12; n_del2_weak=4; peak_fac=1.1 -elif [ $res -eq 96 ]; then - cd4=0.12; max_slope=0.12; n_del2_weak=8; peak_fac=1.1 -elif [ $res -eq 128 ]; then - cd4=0.13; max_slope=0.12; n_del2_weak=8; peak_fac=1.1 -elif [ $res -eq 192 ]; then - cd4=0.15; max_slope=0.12; n_del2_weak=12; peak_fac=1.05 -elif [ $res -eq 384 ]; then - cd4=0.15; max_slope=0.12; n_del2_weak=12; peak_fac=1.0 -elif [ $res -eq 768 ]; then - cd4=0.15; max_slope=0.12; n_del2_weak=16; peak_fac=1.0 -elif [ $res -eq 1152 ]; then - cd4=0.15; max_slope=0.16; n_del2_weak=20; peak_fac=1.0 -elif [ $res -eq 3072 ]; then - cd4=0.15; max_slope=0.30; n_del2_weak=24; peak_fac=1.0 -elif [ $res -eq -999 ]; then - set +x - echo "regional grid filter parameters will be computed later?" - set -x -# use the c768 values for now. - cd4=0.15; max_slope=0.12; n_del2_weak=16; peak_fac=1.0 -else - set +x - echo "grid C$res not supported, exit" - exit 2 -fi - #---------------------------------------------------------------------------------- #---------------------------------------------------------------------------------- # Make grid and orography. @@ -234,7 +202,7 @@ if [ $gtype = uniform ] || [ $gtype = stretch ] || [ $gtype = nest ]; then echo "............ Execute fv3gfs_filter_topo.sh .............." echo set -x - $script_dir/fv3gfs_filter_topo.sh $res $grid_dir $orog_dir $filter_dir $cd4 $peak_fac $max_slope $n_del2_weak $script_dir + $script_dir/fv3gfs_filter_topo.sh $res $grid_dir $orog_dir $filter_dir err=$? if [ $err != 0 ]; then exit $err @@ -370,7 +338,7 @@ elif [ $gtype = regional ]; then echo "............ Execute fv3gfs_filter_topo.sh .............." echo set -x - $script_dir/fv3gfs_filter_topo.sh $res $grid_dir $orog_dir $filter_dir $cd4 $peak_fac $max_slope $n_del2_weak $script_dir + $script_dir/fv3gfs_filter_topo.sh $res $grid_dir $orog_dir $filter_dir err=$? if [ $err != 0 ]; then exit $err @@ -486,7 +454,7 @@ elif [ $gtype = regional_esg ]; then exit $err fi - $script_dir/fv3gfs_filter_topo.sh $res $grid_dir $orog_dir $filter_dir $cd4 $peak_fac $max_slope $n_del2_weak $script_dir + $script_dir/fv3gfs_filter_topo.sh $res $grid_dir $orog_dir $filter_dir err=$? if [ $err != 0 ]; then exit $err diff --git a/ush/fv3gfs_filter_topo.sh b/ush/fv3gfs_filter_topo.sh index a8e6feec9..9ee547acb 100755 --- a/ush/fv3gfs_filter_topo.sh +++ b/ush/fv3gfs_filter_topo.sh @@ -1,10 +1,10 @@ #!/bin/ksh set -ax -if [ $# -ne 9 ]; then +if [ $# -ne 4 ]; then set +x echo - echo "FATAL ERROR: Usage: $0 resolution grid_dir orog_dir out_dir cd4 peak_fac max_slope n_del2_weak script_dir" + echo "FATAL ERROR: Usage: $0 resolution grid_dir orog_dir out_dir" echo set -x exit 1 @@ -16,17 +16,10 @@ else stretch=1.0 fi -if [ $gtype = regional ]; then - refine_ratio=$refine_ratio -else - refine_ratio=1 -fi - export res=$1 export griddir=$2 export orodir=$3 export outdir=$4 -export script_dir=$9 executable=$exec_dir/filter_topo if [ ! -s $executable ]; then @@ -59,14 +52,8 @@ cat > input.nml < Date: Thu, 2 Jul 2020 15:48:02 +0000 Subject: [PATCH 26/38] feature/regional_grid This commit references NOAA-EMC#4 Clean up fv3gfs_filter_topo.sh and fv3gfs_make_grid.sh. --- ush/fv3gfs_filter_topo.sh | 14 +++++- ush/fv3gfs_make_grid.sh | 92 ++++++++++++++++++++++++++------------- 2 files changed, 73 insertions(+), 33 deletions(-) diff --git a/ush/fv3gfs_filter_topo.sh b/ush/fv3gfs_filter_topo.sh index 9ee547acb..ffa0f46d0 100755 --- a/ush/fv3gfs_filter_topo.sh +++ b/ush/fv3gfs_filter_topo.sh @@ -1,6 +1,16 @@ -#!/bin/ksh +#!/bin/bash set -ax +#----------------------------------------------------------------------------------------- +# +# Script name: fv3gfs_filter_topo.sh +# ----------- +# +# Description: Filters the topography. +# ----------- +# +#----------------------------------------------------------------------------------------- + if [ $# -ne 4 ]; then set +x echo @@ -51,7 +61,7 @@ cat > input.nml < Date: Thu, 2 Jul 2020 17:45:01 +0000 Subject: [PATCH 27/38] feature/regional_grid This commit references NOAA-EMC#4 Combine shave logic for both regional grid types. --- ush/fv3gfs_driver_grid.sh | 102 ++++++++++++++------------------------ ush/fv3gfs_make_orog.sh | 2 +- 2 files changed, 39 insertions(+), 65 deletions(-) diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh index fee8c1d1e..3bd4cf506 100755 --- a/ush/fv3gfs_driver_grid.sh +++ b/ush/fv3gfs_driver_grid.sh @@ -249,8 +249,8 @@ elif [ $gtype = regional ]; then # Number of compute grid points #---------------------------------------------------------------------------------- - npts_cgx=`expr $nptsx \* $refine_ratio / 2` - npts_cgy=`expr $nptsy \* $refine_ratio / 2` + idim=`expr $nptsx \* $refine_ratio / 2` + jdim=`expr $nptsy \* $refine_ratio / 2` #---------------------------------------------------------------------------------- # Figure out how many columns/rows to add in each direction so we have at least @@ -266,7 +266,7 @@ elif [ $gtype = regional ]; then istart_nest_halo=`expr $istart_nest - $add_subtract_value` newpoints_i=`expr $iend_nest_halo - $istart_nest_halo + 1` newpoints_cg_i=`expr $newpoints_i \* $refine_ratio / 2` - diff=`expr $newpoints_cg_i - $npts_cgx` + diff=`expr $newpoints_cg_i - $idim` if [ $diff -ge 10 ]; then index=`expr $index + 1` fi @@ -343,63 +343,7 @@ elif [ $gtype = regional ]; then if [ $err != 0 ]; then exit $err fi - set +x - echo - echo "............ Execute shave to reduce grid and orography files to required compute size .............." - echo - set -x - cd $filter_dir - -#---------------------------------------------------------------------------------- -# Shave the orography file and then the grid file, the echo creates the input -# file that contains the number of required points in x and y and the input -# and output file names.This first run of shave uses a halo of 4. -# This is necessary so that chgres will create BC's with 4 rows/columns which is -# necessary for pt. -#---------------------------------------------------------------------------------- - - echo $npts_cgx $npts_cgy $halop1 \'$filter_dir/oro.C${res}.tile${tile}.nc\' \'$filter_dir/oro.C${res}.tile${tile}.shave.nc\' >input.shave.orog - echo $npts_cgx $npts_cgy $halop1 \'$filter_dir/C${res}_grid.tile${tile}.nc\' \'$filter_dir/C${res}_grid.tile${tile}.shave.nc\' >input.shave.grid - - $APRUN $exec_dir/shave input.shave.orog.halo$halo - echo $npts_cgx $npts_cgy $halo \'$filter_dir/C${res}_grid.tile${tile}.nc\' \'$filter_dir/C${res}_grid.tile${tile}.shave.nc\' >input.shave.grid.halo$halo - $APRUN $exec_dir/shave input.shave.orog.halo0 - echo $npts_cgx $npts_cgy 0 \'$filter_dir/C${res}_grid.tile${tile}.nc\' \'$filter_dir/C${res}_grid.tile${tile}.shave.nc\' >input.shave.grid.halo0 - - $APRUN $exec_dir/shave input.shave.orog @@ -470,6 +438,11 @@ elif [ $gtype = regional_esg ]; then cp $filter_dir/oro.C${res}.tile${tile}.shave.nc $out_dir/C${res}_oro_data.tile${tile}.halo${halop1}.nc cp $filter_dir/C${res}_grid.tile${tile}.shave.nc $out_dir/C${res}_grid.tile${tile}.halo${halop1}.nc + +#---------------------------------------------------------------------------------- +# Now shave the orography file and then the grid file with a halo of 3. +# This is necessary for running the model. +#---------------------------------------------------------------------------------- echo $idim $jdim $halo \'$filter_dir/oro.C${res}.tile${tile}.nc\' \'$filter_dir/oro.C${res}.tile${tile}.shave.nc\' >input.shave.orog.halo$halo echo $idim $jdim $halo \'$filter_dir/C${res}_grid.tile${tile}.nc\' \'$filter_dir/C${res}_grid.tile${tile}.shave.nc\' >input.shave.grid.halo$halo @@ -479,6 +452,11 @@ elif [ $gtype = regional_esg ]; then cp $filter_dir/oro.C${res}.tile${tile}.shave.nc $out_dir/C${res}_oro_data.tile${tile}.halo${halo}.nc cp $filter_dir/C${res}_grid.tile${tile}.shave.nc $out_dir/C${res}_grid.tile${tile}.halo${halo}.nc + +#---------------------------------------------------------------------------------- +# Now shave the orography file and then the grid file with a halo of 0. +# This is handy for running chgres. +#---------------------------------------------------------------------------------- echo $idim $jdim 0 \'$filter_dir/oro.C${res}.tile${tile}.nc\' \'$filter_dir/oro.C${res}.tile${tile}.shave.nc\' >input.shave.orog.halo0 echo $idim $jdim 0 \'$filter_dir/C${res}_grid.tile${tile}.nc\' \'$filter_dir/C${res}_grid.tile${tile}.shave.nc\' >input.shave.grid.halo0 @@ -488,15 +466,11 @@ elif [ $gtype = regional_esg ]; then cp $filter_dir/oro.C${res}.tile${tile}.shave.nc $out_dir/C${res}_oro_data.tile${tile}.halo0.nc cp $filter_dir/C${res}_grid.tile${tile}.shave.nc $out_dir/C${res}_grid.tile${tile}.halo0.nc - + cp $grid_dir/C${res}_*mosaic.nc $out_dir echo "Grid and orography files are now prepared for regional grid" -#---------------------------------------------------------------------------------- -# End of block to create grid and orog files. -#---------------------------------------------------------------------------------- - fi #------------------------------------------------------------------------------------ diff --git a/ush/fv3gfs_make_orog.sh b/ush/fv3gfs_make_orog.sh index 7e8960d5c..7a52122fb 100755 --- a/ush/fv3gfs_make_orog.sh +++ b/ush/fv3gfs_make_orog.sh @@ -1,4 +1,4 @@ -#!/bin/ksh +#!/bin/bash set -ax nargv=$# From c452f1f01cd067fff4bcce6d4626f378f364c87a Mon Sep 17 00:00:00 2001 From: George Gayno Date: Thu, 2 Jul 2020 18:36:05 +0000 Subject: [PATCH 28/38] feature/regional_grid This commit references NOAA-EMC#4 Combine orography logic for regional grids in fv3gfs_driver_grid.sh. --- ush/fv3gfs_driver_grid.sh | 96 ++++++++++++--------------------------- 1 file changed, 30 insertions(+), 66 deletions(-) diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh index 3bd4cf506..408bda25b 100755 --- a/ush/fv3gfs_driver_grid.sh +++ b/ush/fv3gfs_driver_grid.sh @@ -301,49 +301,6 @@ elif [ $gtype = regional ]; then exit $err fi -# redefine res for gfdl regional grids. - - res=$( ncdump -h ${grid_dir}/C*_grid.tile7.nc | grep -o ":RES_equiv = [0-9]\+" | grep -o "[0-9]" ) - res=${res//$'\n'/} - out_dir=$out_dir/C${res} - mkdir -p $out_dir - - echo "Begin regional orography generation at `date`" - -#---------------------------------------------------------------------------------- -# On WCOSS_C use cfp to run multiple tiles simulatneously for the orography. -# For now we only have one tile but in the future we will have more. -#---------------------------------------------------------------------------------- - - if [ $machine = WCOSS_C ]; then - echo "$script_dir/fv3gfs_make_orog.sh $res 7 $grid_dir $orog_dir $script_dir $topo $TMPDIR " >>$TMPDIR/orog.file1 - aprun -j 1 -n 4 -N 4 -d 6 -cc depth cfp $TMPDIR/orog.file1 - err=$? - rm $TMPDIR/orog.file1 - else - set +x - echo - echo "............ Execute fv3gfs_make_orog.sh for tile $tile .................." - echo - set -x - $script_dir/fv3gfs_make_orog.sh $res $tile $grid_dir $orog_dir $script_dir $topo $TMPDIR - err=$? - if [ $err != 0 ]; then - exit $err - fi - fi - - set +x - echo - echo "............ Execute fv3gfs_filter_topo.sh .............." - echo - set -x - $script_dir/fv3gfs_filter_topo.sh $res $grid_dir $orog_dir $filter_dir - err=$? - if [ $err != 0 ]; then - exit $err - fi - #---------------------------------------------------------------------------------- elif [ $gtype = regional_esg ]; then @@ -368,18 +325,36 @@ elif [ $gtype = regional_esg ]; then exit $err fi +#---------------------------------------------------------------------------------- +# End of block to create grid and orog files. +#---------------------------------------------------------------------------------- + +fi + +#---------------------------------------------------------------------------------- +# For regional grids, shave the orography file and then the grid file, the echo +# creates the file that contains the number of required points in x and y and the +# input and output file names.This first run of shave uses a halo of 4. +# This is necessary so that chgres will create BC's with 4 rows/columns which is +# necessary for pt. +#---------------------------------------------------------------------------------- + +if [ $gtype = regional ] || [ $gtype = regional_esg ]; then + +# redefine res for regional grids. + res=$( ncdump -h ${grid_dir}/C*_grid.tile7.nc | grep -o ":RES_equiv = [0-9]\+" | grep -o "[0-9]" ) res=${res//$'\n'/} out_dir=$out_dir/C${res} mkdir -p $out_dir - echo "Begin orography generation at `date`" - #---------------------------------------------------------------------------------- # On WCOSS_C use cfp to run multiple tiles simulatneously for the orography. # For now we only have one tile but in the future we will have more. #---------------------------------------------------------------------------------- + echo "Begin orography generation at `date`" + if [ $machine = WCOSS_C ]; then echo "$script_dir/fv3gfs_make_orog.sh $res $tile $grid_dir $orog_dir $script_dir $topo $TMPDIR " >>$TMPDIR/orog.file1 aprun -j 1 -n 4 -N 4 -d 6 -cc depth cfp $TMPDIR/orog.file1 @@ -393,35 +368,24 @@ elif [ $gtype = regional_esg ]; then set -x $script_dir/fv3gfs_make_orog.sh $res $tile $grid_dir $orog_dir $script_dir $topo $TMPDIR err=$? + if [ $err != 0 ]; then + exit $err + fi fi - if [ $err != 0 ]; then - exit $err - fi + echo "Grid and orography files are now prepared." + + set +x + echo + echo "............ Execute fv3gfs_filter_topo.sh .............." + echo + set -x $script_dir/fv3gfs_filter_topo.sh $res $grid_dir $orog_dir $filter_dir err=$? if [ $err != 0 ]; then exit $err fi - echo "Grid and orography files are now prepared for regional_esg grid" - -#---------------------------------------------------------------------------------- -# End of block to create grid and orog files. -#---------------------------------------------------------------------------------- - -fi - -#---------------------------------------------------------------------------------- -# For regional grids, shave the orography file and then the grid file, the echo -# creates the file that contains the number of required points in x and y and the -# input and output file names.This first run of shave uses a halo of 4. -# This is necessary so that chgres will create BC's with 4 rows/columns which is -# necessary for pt. -#---------------------------------------------------------------------------------- - -if [ $gtype = regional ] || [ $gtype = regional_esg ]; then - set +x echo echo "............ Execute shave to reduce grid and orography files to required compute size .............." From 38eeaee89d4a6498a999db53b10e08415faead5f Mon Sep 17 00:00:00 2001 From: George Gayno Date: Thu, 2 Jul 2020 19:36:37 +0000 Subject: [PATCH 29/38] feature/regional_grid This commit references NOAA-EMC#4 Change fv3gfs_make_grid.sh back to ksh so it works on the Cray. --- ush/fv3gfs_make_grid.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ush/fv3gfs_make_grid.sh b/ush/fv3gfs_make_grid.sh index c46e0069e..a9c940200 100755 --- a/ush/fv3gfs_make_grid.sh +++ b/ush/fv3gfs_make_grid.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/bin/ksh set -ax @@ -36,7 +36,7 @@ set -ax # Retrieve global equivalent resolution from grid file. #----------------------------------------------------------------------------------------- -function get_res() +function get_res { res=$( ncdump -h $1 | grep -o ":RES_equiv = [0-9]\+" | grep -o "[0-9]" ) res=${res//$'\n'/} From bdfe3f60d3a91ab0bdf5251eb09aa156c93f8fb6 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Thu, 2 Jul 2020 20:40:19 +0000 Subject: [PATCH 30/38] feature/regional_grid This commit references NOAA-EMC#4 Continue to consolodate logic for regional grids. --- ush/fv3gfs_driver_grid.sh | 164 ++++++++++++++++++-------------------- 1 file changed, 77 insertions(+), 87 deletions(-) diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh index 408bda25b..d583ceb4e 100755 --- a/ush/fv3gfs_driver_grid.sh +++ b/ush/fv3gfs_driver_grid.sh @@ -103,9 +103,11 @@ cd $TMPDIR ||exit 8 #---------------------------------------------------------------------------------- #---------------------------------------------------------------------------------- +#---------------------------------------------------------------------------------- #---------------------------------------------------------------------------------- # Uniform, stretch or nest grid. #---------------------------------------------------------------------------------- +#---------------------------------------------------------------------------------- if [ $gtype = uniform ] || [ $gtype = stretch ] || [ $gtype = nest ]; then @@ -223,11 +225,13 @@ if [ $gtype = uniform ] || [ $gtype = stretch ] || [ $gtype = nest ]; then echo "Grid and orography files are now prepared." +#---------------------------------------------------------------------------------- #---------------------------------------------------------------------------------- # Regional grid. #---------------------------------------------------------------------------------- +#---------------------------------------------------------------------------------- -elif [ $gtype = regional ]; then +elif [ $gtype = regional ] || [ $gtype = regional_esg ]; then #---------------------------------------------------------------------------------- # We are now creating only 1 tile and it is tile 7 @@ -236,119 +240,97 @@ elif [ $gtype = regional ]; then export ntiles=1 halop1=$(( halo + 1 )) tile=7 - set +x # don't echo all the computation to figure out how many points to add/subtract from start/end nest values - + name=regional + grid_dir=$TMPDIR/${name}/grid + orog_dir=$TMPDIR/${name}/orog + filter_dir=$orog_dir # nested grid topography will be filtered online + rm -rf $TMPDIR/$name + mkdir -p $grid_dir $orog_dir $filter_dir + #---------------------------------------------------------------------------------- -# Number of parent points +# Create regional gfdl grid files. #---------------------------------------------------------------------------------- + + if [ $gtype = regional ]; then + + set +x # don't echo all the computation to figure out how many points to add/subtract from start/end nest values - nptsx=`expr $iend_nest - $istart_nest + 1` - nptsy=`expr $jend_nest - $jstart_nest + 1` - -#---------------------------------------------------------------------------------- -# Number of compute grid points -#---------------------------------------------------------------------------------- + nptsx=`expr $iend_nest - $istart_nest + 1` # parent points + nptsy=`expr $jend_nest - $jstart_nest + 1` - idim=`expr $nptsx \* $refine_ratio / 2` - jdim=`expr $nptsy \* $refine_ratio / 2` + idim=`expr $nptsx \* $refine_ratio / 2` # number of compute points + jdim=`expr $nptsy \* $refine_ratio / 2` #---------------------------------------------------------------------------------- # Figure out how many columns/rows to add in each direction so we have at least # 5 halo points for make_hgrid and the orography program. #---------------------------------------------------------------------------------- - index=0 - add_subtract_value=0 - while (test "$index" -le "0") - do - add_subtract_value=`expr $add_subtract_value + 1` - iend_nest_halo=`expr $iend_nest + $add_subtract_value` - istart_nest_halo=`expr $istart_nest - $add_subtract_value` - newpoints_i=`expr $iend_nest_halo - $istart_nest_halo + 1` - newpoints_cg_i=`expr $newpoints_i \* $refine_ratio / 2` - diff=`expr $newpoints_cg_i - $idim` - if [ $diff -ge 10 ]; then - index=`expr $index + 1` - fi - done - jend_nest_halo=`expr $jend_nest + $add_subtract_value` - jstart_nest_halo=`expr $jstart_nest - $add_subtract_value` - - echo "================================================================================== " - echo "For refine_ratio= $refine_ratio" - echo " iend_nest= $iend_nest iend_nest_halo= $iend_nest_halo istart_nest= $istart_nest istart_nest_halo= $istart_nest_halo" - echo " jend_nest= $jend_nest jend_nest_halo= $jend_nest_halo jstart_nest= $jstart_nest jstart_nest_halo= $jstart_nest_halo" - echo "================================================================================== " - set -x + index=0 + add_subtract_value=0 + while (test "$index" -le "0") + do + add_subtract_value=`expr $add_subtract_value + 1` + iend_nest_halo=`expr $iend_nest + $add_subtract_value` + istart_nest_halo=`expr $istart_nest - $add_subtract_value` + newpoints_i=`expr $iend_nest_halo - $istart_nest_halo + 1` + newpoints_cg_i=`expr $newpoints_i \* $refine_ratio / 2` + diff=`expr $newpoints_cg_i - $idim` + if [ $diff -ge 10 ]; then + index=`expr $index + 1` + fi + done + jend_nest_halo=`expr $jend_nest + $add_subtract_value` + jstart_nest_halo=`expr $jstart_nest - $add_subtract_value` + + echo "================================================================================== " + echo "For refine_ratio= $refine_ratio" + echo " iend_nest= $iend_nest iend_nest_halo= $iend_nest_halo istart_nest= $istart_nest istart_nest_halo= $istart_nest_halo" + echo " jend_nest= $jend_nest jend_nest_halo= $jend_nest_halo jstart_nest= $jstart_nest jstart_nest_halo= $jstart_nest_halo" + echo "================================================================================== " - export ntiles=1 - tile=7 - name=gfdl - grid_dir=$TMPDIR/${name}/grid - orog_dir=$TMPDIR/$name/orog - filter_dir=$orog_dir # nested grid topography will be filtered online - rm -rf $TMPDIR/$name - mkdir -p $grid_dir $orog_dir $filter_dir - - set +x - echo - echo "............ Execute fv3gfs_make_grid.sh ................." - echo - set -x - $script_dir/fv3gfs_make_grid.sh $grid_dir $istart_nest_halo $jstart_nest_halo $iend_nest_halo $jend_nest_halo - err=$? - if [ $err != 0 ]; then - exit $err - fi + set +x + echo + echo "............ Execute fv3gfs_make_grid.sh ................." + echo + set -x + $script_dir/fv3gfs_make_grid.sh $grid_dir $istart_nest_halo $jstart_nest_halo $iend_nest_halo $jend_nest_halo + err=$? + if [ $err != 0 ]; then + exit $err + fi +#---------------------------------------------------------------------------------- +# Create regional esg grid files. #---------------------------------------------------------------------------------- -elif [ $gtype = regional_esg ]; then + elif [ $gtype = regional_esg ]; then - halop1=$(( halo + 1 )) - tile=7 - name=regional_esg - grid_dir=$TMPDIR/${name}/grid - orog_dir=$TMPDIR/${name}/orog - filter_dir=$TMPDIR/${name}/filter_topo - rm -rf $TMPDIR/$name - mkdir -p $grid_dir $orog_dir $filter_dir + set +x + echo + echo "............ Execute fv3gfs_make_grid.sh ................." + echo + set -x + $script_dir/fv3gfs_make_grid.sh $grid_dir + err=$? + if [ $err != 0 ]; then + exit $err + fi - set +x - echo - echo "............ Execute fv3gfs_make_grid.sh ................." - echo - set -x - $script_dir/fv3gfs_make_grid.sh $grid_dir - err=$? - if [ $err != 0 ]; then - exit $err fi #---------------------------------------------------------------------------------- -# End of block to create grid and orog files. +# Redefine resolution for regional grids as a global equivalent resolution. #---------------------------------------------------------------------------------- -fi - -#---------------------------------------------------------------------------------- -# For regional grids, shave the orography file and then the grid file, the echo -# creates the file that contains the number of required points in x and y and the -# input and output file names.This first run of shave uses a halo of 4. -# This is necessary so that chgres will create BC's with 4 rows/columns which is -# necessary for pt. -#---------------------------------------------------------------------------------- - -if [ $gtype = regional ] || [ $gtype = regional_esg ]; then - -# redefine res for regional grids. - res=$( ncdump -h ${grid_dir}/C*_grid.tile7.nc | grep -o ":RES_equiv = [0-9]\+" | grep -o "[0-9]" ) res=${res//$'\n'/} out_dir=$out_dir/C${res} mkdir -p $out_dir #---------------------------------------------------------------------------------- +# Create orography. +# # On WCOSS_C use cfp to run multiple tiles simulatneously for the orography. # For now we only have one tile but in the future we will have more. #---------------------------------------------------------------------------------- @@ -386,6 +368,14 @@ if [ $gtype = regional ] || [ $gtype = regional_esg ]; then exit $err fi +#---------------------------------------------------------------------------------- +# For regional grids, shave the orography file and then the grid file, the echo +# creates the file that contains the number of required points in x and y and the +# input and output file names.This first run of shave uses a halo of 4. +# This is necessary so that chgres will create BC's with 4 rows/columns which is +# necessary for pt. +#---------------------------------------------------------------------------------- + set +x echo echo "............ Execute shave to reduce grid and orography files to required compute size .............." From 03ff9061883df1dafaa107ac204c77087e7df20d Mon Sep 17 00:00:00 2001 From: George Gayno Date: Thu, 2 Jul 2020 21:30:09 +0000 Subject: [PATCH 31/38] feature/regional_grid This commit references NOAA-EMC#4 Rename gfdl regional flag to be 'regional_gfdl' in all scripts. --- driver_scripts/driver_grid.cray.sh | 20 +++++++++++++------- driver_scripts/driver_grid.dell.sh | 20 +++++++++++++------- driver_scripts/driver_grid.hera.sh | 20 +++++++++++++------- driver_scripts/driver_grid.jet.sh | 20 +++++++++++++------- ush/fv3gfs_driver_grid.sh | 23 +++++++++++++---------- ush/fv3gfs_filter_topo.sh | 4 ++-- ush/fv3gfs_make_grid.sh | 12 ++++++------ 7 files changed, 73 insertions(+), 46 deletions(-) diff --git a/driver_scripts/driver_grid.cray.sh b/driver_scripts/driver_grid.cray.sh index 78a01628d..256b782cd 100755 --- a/driver_scripts/driver_grid.cray.sh +++ b/driver_scripts/driver_grid.cray.sh @@ -33,19 +33,24 @@ # "uniform" - global uniform grid # "stretch" - global stretched grid # "nest" - global stretched grid with nest -# "regional" - stand-alone regional grid +# "regional_gfdl" - stand-alone gfdl regional grid +# "regional_esg" - stand-alone extended Schmidt gnominic +# (esg) regional grid # 3) For "stretch" and "nest" grids, set the stretching factor - # "stretch_fac", and center lat/lon of highest resolution # tile - "target_lat" and "target_lon". # 4) For "nest" grids, set the refinement ratio - "refine_ratio", # the starting/ending i/j index location within the parent # tile - "istart_nest", "jstart_nest", "iend_nest", "jend_nest" -# 5) For "regional" grids, set the "halo". Default is three +# 5) For "regional_gfdl" grids, set the "halo". Default is three # rows/columns. -# 6) Set working directory - TMPDIR - and path to the repository +# 6) For "regional_esg" grids, set center lat/lon of grid, +# - "target_lat/lon" - the i/j dimensions - "i/jdim", the +# x/y grid spacing - "delx/y", and halo. +# 7) Set working directory - TMPDIR - and path to the repository # clone - home_dir. -# 7) Submit script: "cat $script | bsub". -# 8) All files will be placed in "out_dir". +# 8) Submit script: "cat $script | bsub". +# 9) All files will be placed in "out_dir". # #----------------------------------------------------------------------- @@ -57,7 +62,8 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export gtype=regional_esg # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=regional_esg # 'uniform', 'stretch', 'nest' + # 'regional_gfdl', 'regional_esg' if [ $gtype = uniform ]; then export res=96 @@ -66,7 +72,7 @@ elif [ $gtype = stretch ]; then export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile export target_lat=35.5 # Center latitude of the highest resolution tile -elif [ $gtype = nest ] || [ $gtype = regional ]; then +elif [ $gtype = nest ] || [ $gtype = regional_gfdl ]; then export res=96 export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile diff --git a/driver_scripts/driver_grid.dell.sh b/driver_scripts/driver_grid.dell.sh index fc6dd0b59..0fef8e913 100755 --- a/driver_scripts/driver_grid.dell.sh +++ b/driver_scripts/driver_grid.dell.sh @@ -35,19 +35,24 @@ # "uniform" - global uniform grid # "stretch" - global stretched grid # "nest" - global stretched grid with nest -# "regional" - stand-alone regional grid +# "regional_gfdl" - stand-alone gfdl regional grid +# "regional_esg" - stand-alone extended Schmidt gnominic +# (esg) regional grid # 3) For "stretch" and "nest" grids, set the stretching factor - # "stretch_fac", and center lat/lon of highest resolution # tile - "target_lat" and "target_lon". # 4) For "nest" grids, set the refinement ratio - "refine_ratio", # the starting/ending i/j index location within the parent # tile - "istart_nest", "jstart_nest", "iend_nest", "jend_nest" -# 5) For "regional" grids, set the "halo". Default is three +# 5) For "regional_gfdl" grids, set the "halo". Default is three # rows/columns. -# 6) Set working directory - TMPDIR - and path to the repository +# 6) For "regional_esg" grids, set center lat/lon of grid, +# - "target_lat/lon" - the i/j dimensions - "i/jdim", the +# x/y grid spacing - "delx/y", and halo. +# 7) Set working directory - TMPDIR - and path to the repository # clone - home_dir. -# 7) Submit script: "cat $script | bsub". -# 8) All files will be placed in "out_dir". +# 8) Submit script: "cat $script | bsub". +# 9) All files will be placed in "out_dir". # #----------------------------------------------------------------------- @@ -59,7 +64,8 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export gtype=regional_esg # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=regional_gfdl # 'uniform', 'stretch', 'nest', + # 'regional_gfdl', 'regional_esg' if [ $gtype = uniform ]; then export res=96 @@ -68,7 +74,7 @@ elif [ $gtype = stretch ]; then export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile export target_lat=35.5 # Center latitude of the highest resolution tile -elif [ $gtype = nest ] || [ $gtype = regional ]; then +elif [ $gtype = nest ] || [ $gtype = regional_gfdl ]; then export res=96 export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile diff --git a/driver_scripts/driver_grid.hera.sh b/driver_scripts/driver_grid.hera.sh index a5000634f..50007fae3 100755 --- a/driver_scripts/driver_grid.hera.sh +++ b/driver_scripts/driver_grid.hera.sh @@ -33,19 +33,24 @@ # "uniform" - global uniform grid # "stretch" - global stretched grid # "nest" - global stretched grid with nest -# "regional" - stand-alone regional grid +# "regional_gfdl" - stand-alone gfdl regional grid +# "regional_esg" - stand-alone extended Schmidt gnominic +# (esg) regional grid # 3) For "stretch" and "nest" grids, set the stretching factor - # "stretch_fac", and center lat/lon of highest resolution # tile - "target_lat" and "target_lon". # 4) For "nest" grids, set the refinement ratio - "refine_ratio", # the starting/ending i/j index location within the parent # tile - "istart_nest", "jstart_nest", "iend_nest", "jend_nest" -# 5) For "regional" grids, set the "halo". Default is three +# 5) For "regional_gfdl" grids, set the "halo". Default is three # rows/columns. -# 6) Set working directory - TMPDIR - and path to the repository +# 6) For "regional_esg" grids, set center lat/lon of grid, +# - "target_lat/lon" - the i/j dimensions - "i/jdim", the +# x/y grid spacing - "delx/y", and halo. +# 7) Set working directory - TMPDIR - and path to the repository # clone - home_dir. -# 7) Submit script: "sbatch $script". -# 8) All files will be placed in "out_dir". +# 8) Submit script: "sbatch $script". +# 9) All files will be placed in "out_dir". # #----------------------------------------------------------------------- @@ -59,7 +64,8 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export gtype=regional_esg # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=regional_esg # 'uniform', 'stretch', 'nest' + # 'regional_gfdl', 'regional_esg' if [ $gtype = uniform ]; then export res=96 @@ -68,7 +74,7 @@ elif [ $gtype = stretch ]; then export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile export target_lat=35.5 # Center latitude of the highest resolution tile -elif [ $gtype = nest ] || [ $gtype = regional ]; then +elif [ $gtype = nest ] || [ $gtype = regional_gfdl ]; then export res=96 export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile diff --git a/driver_scripts/driver_grid.jet.sh b/driver_scripts/driver_grid.jet.sh index 3ecb7b997..b88c2f53c 100755 --- a/driver_scripts/driver_grid.jet.sh +++ b/driver_scripts/driver_grid.jet.sh @@ -34,19 +34,24 @@ # "uniform" - global uniform grid # "stretch" - global stretched grid # "nest" - global stretched grid with nest -# "regional" - stand-alone regional grid +# "regional_gfdl" - stand-alone gfdl regional grid +# "regional_esg" - stand-alone extended Schmidt gnominic +# (esg) regional grid # 3) For "stretch" and "nest" grids, set the stretching factor - # "stretch_fac", and center lat/lon of highest resolution # tile - "target_lat" and "target_lon". # 4) For "nest" grids, set the refinement ratio - "refine_ratio", # the starting/ending i/j index location within the parent # tile - "istart_nest", "jstart_nest", "iend_nest", "jend_nest" -# 5) For "regional" grids, set the "halo". Default is three +# 5) For "regional_gfdl" grids, set the "halo". Default is three # rows/columns. -# 6) Set working directory - TMPDIR - and path to the repository +# 6) For "regional_esg" grids, set center lat/lon of grid, +# - "target_lat/lon" - the i/j dimensions - "i/jdim", the +# x/y grid spacing - "delx/y", and halo. +# 7) Set working directory - TMPDIR - and path to the repository # clone - home_dir. -# 7) Submit script: "sbatch $script". -# 8) All files will be placed in "out_dir". +# 8) Submit script: "sbatch $script". +# 9) All files will be placed in "out_dir". # #----------------------------------------------------------------------- @@ -60,7 +65,8 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export gtype=regional_esg # 'uniform', 'stretch', 'nest', or 'regional' +export gtype=regional_esg # 'uniform', 'stretch', 'nest' + # 'regional_gfdl', 'regional_esg' if [ $gtype = uniform ]; then export res=96 @@ -69,7 +75,7 @@ elif [ $gtype = stretch ]; then export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile export target_lat=35.5 # Center latitude of the highest resolution tile -elif [ $gtype = nest ] || [ $gtype = regional ]; then +elif [ $gtype = nest ] || [ $gtype = regional_gfdl ]; then export res=96 export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh index d583ceb4e..2f4b2985a 100755 --- a/ush/fv3gfs_driver_grid.sh +++ b/ush/fv3gfs_driver_grid.sh @@ -7,7 +7,8 @@ # 1) global uniform # 2) global stretched # 3) global stretched with nest -# 4) stand-alone regional +# 4) stand-alone GFDL regional +# 5) stand-alone extended Schmidt gnonomic (ESG) regional # # Produces the following files (netcdf, each tile in separate file): # 1) 'mosaic' and 'grid' files containing lat/lon and other @@ -41,7 +42,8 @@ export machine=${machine:?} #---------------------------------------------------------------------------------- export res=${res:-96} # resolution of tile: 48, 96, 128, 192, 384, 768, 1152, 3072 -export gtype=${gtype:-uniform} # grid type: uniform, stretch, nest or regional +export gtype=${gtype:-uniform} # grid type: uniform, stretch, nest, regional_gfdl + # or regional_esg if [ $gtype = uniform ]; then echo "Creating global uniform grid" @@ -51,7 +53,7 @@ elif [ $gtype = stretch ]; then export target_lat=${target_lat:-35.5} # Center latitude of the highest resolution tile title=c${res}s echo "Creating global stretched grid" -elif [ $gtype = nest ] || [ $gtype = regional ]; then +elif [ $gtype = nest ] || [ $gtype = regional_gfdl ]; then export stretch_fac=${stretch_fac:-1.5} # Stretching factor for the grid export target_lon=${target_lon:--97.5} # Center longitude of the highest resolution tile export target_lat=${target_lat:-35.5} # Center latitude of the highest resolution tile @@ -65,9 +67,10 @@ elif [ $gtype = nest ] || [ $gtype = regional ]; then if [ $gtype = nest ];then echo "Creating global nested grid" else - echo "Creating regional grid" + echo "Creating gfdl regional grid" fi elif [ $gtype = regional_esg ]; then + echo "Creating esg regional grid" export target_lon=${target_lon:--97.5} # Center longitude of grid export target_lat=${target_lat:-35.5} # Center latitude of grid export idim=${idim:-200} # Dimension of grid in 'i' direction @@ -81,7 +84,7 @@ elif [ $gtype = regional_esg ]; then export halo=${halo:-3} # Number of rows/cols for halo. title=esg else - echo "Error: please specify grid type with 'gtype' as uniform, stretch, nest or regional" + echo "Error: please specify grid type with 'gtype' as uniform, stretch, nest, regional_gfdl or regional_esg" exit 9 fi @@ -227,11 +230,11 @@ if [ $gtype = uniform ] || [ $gtype = stretch ] || [ $gtype = nest ]; then #---------------------------------------------------------------------------------- #---------------------------------------------------------------------------------- -# Regional grid. +# Regional grid (gfdl or esg) #---------------------------------------------------------------------------------- #---------------------------------------------------------------------------------- -elif [ $gtype = regional ] || [ $gtype = regional_esg ]; then +elif [ $gtype = regional_gfdl ] || [ $gtype = regional_esg ]; then #---------------------------------------------------------------------------------- # We are now creating only 1 tile and it is tile 7 @@ -251,7 +254,7 @@ elif [ $gtype = regional ] || [ $gtype = regional_esg ]; then # Create regional gfdl grid files. #---------------------------------------------------------------------------------- - if [ $gtype = regional ]; then + if [ $gtype = regional_gfdl ]; then set +x # don't echo all the computation to figure out how many points to add/subtract from start/end nest values @@ -444,7 +447,7 @@ export BASE_DIR=$home_dir export FIX_FV3=$out_dir export input_sfc_climo_dir=$home_dir/fix/fix_sfc_climo -if [ $gtype = regional ] || [ $gtype = regional_esg ]; then +if [ $gtype = regional_gfdl ] || [ $gtype = regional_esg ]; then export HALO=$halop1 ln -fs $out_dir/C${res}_grid.tile${tile}.halo${HALO}.nc $out_dir/C${res}_grid.tile${tile}.nc ln -fs $out_dir/C${res}_oro_data.tile${tile}.halo${HALO}.nc $out_dir/C${res}_oro_data.tile${tile}.nc @@ -460,7 +463,7 @@ if [ $err != 0 ]; then exit $err fi -if [ $gtype = regional ] || [ $gtype = regional_esg ]; then +if [ $gtype = regional_gfdl ] || [ $gtype = regional_esg ]; then rm -f $out_dir/C${res}_grid.tile${tile}.nc rm -f $out_dir/C${res}_oro_data.tile${tile}.nc fi diff --git a/ush/fv3gfs_filter_topo.sh b/ush/fv3gfs_filter_topo.sh index ffa0f46d0..9685d9ad7 100755 --- a/ush/fv3gfs_filter_topo.sh +++ b/ush/fv3gfs_filter_topo.sh @@ -20,7 +20,7 @@ if [ $# -ne 4 ]; then exit 1 fi -if [ $gtype = stretch ] || [ $gtype = regional ]; then +if [ $gtype = stretch ] || [ $gtype = regional_gfdl ]; then stretch=$stretch_fac else stretch=1.0 @@ -53,7 +53,7 @@ cp $orodir/${topo_file}.tile?.nc . cp $executable . regional=.false. -if [ $gtype = regional ] || [ $gtype = regional_esg ] ; then +if [ $gtype = regional_gfdl ] || [ $gtype = regional_esg ] ; then regional=.true. fi diff --git a/ush/fv3gfs_make_grid.sh b/ush/fv3gfs_make_grid.sh index a9c940200..d4c6581fd 100755 --- a/ush/fv3gfs_make_grid.sh +++ b/ush/fv3gfs_make_grid.sh @@ -16,7 +16,7 @@ set -ax # APRUN Command to invoke executables # exec_dir Location of executables # gtype Grid type. 'uniform' - global uniform; 'stretch' - global -# stretched; 'nest' - global stretched with nest; 'regional' - +# stretched; 'nest' - global stretched with nest; 'regional_gfdl' - # stand alone GFDL regional nest; 'regional_esg' - stand alone # extended Schmidt gnomonic regional grid. # halo Lateral boundary halo size, regional grids only. @@ -85,7 +85,7 @@ elif [ $gtype = stretch ]; then ntiles=6 $APRUN $executable --grid_type gnomonic_ed --nlon $nx --grid_name C${res}_grid \ --do_schmidt --stretch_factor ${stretch_fac} --target_lon ${target_lon} --target_lat ${target_lat} -elif [ $gtype = nest ] || [ $gtype = regional ] ; then +elif [ $gtype = nest ] || [ $gtype = regional_gfdl ] ; then stretch_fac=${stretch_fac:?} target_lon=${target_lon:?} target_lat=${target_lat:?} @@ -95,7 +95,7 @@ elif [ $gtype = nest ] || [ $gtype = regional ] ; then iend_nest=$4 jend_nest=$5 halo=${halo:?} - if [ $gtype = regional ]; then + if [ $gtype = regional_gfdl ]; then ntiles=1 else ntiles=7 @@ -143,7 +143,7 @@ fi # Below, this attribute is retrieved and used to rename the grid files. #--------------------------------------------------------------------------------------- -if [ $gtype = regional ] || [ $gtype = regional_esg ]; then +if [ $gtype = regional_gfdl ] || [ $gtype = regional_esg ]; then executable=$exec_dir/global_equiv_resol if [ ! -s $executable ]; then set +x @@ -155,7 +155,7 @@ if [ $gtype = regional ] || [ $gtype = regional_esg ]; then fi if [ $gtype = regional_esg ]; then $APRUN $executable regional_grid.nc - elif [ $gtype = regional ]; then + elif [ $gtype = regional_gfdl ]; then $APRUN $executable C${res}_grid.tile7.nc fi if [ $? -ne 0 ]; then @@ -206,7 +206,7 @@ elif [ $gtype = nest ]; then $APRUN $executable --num_tiles 1 --dir $outdir --mosaic C${res}_nested_mosaic --tile_file C${res}_grid.tile7.nc -elif [ $gtype = regional ];then +elif [ $gtype = regional_gfdl ];then res_save=$res get_res C${res}_grid.tile7.nc From e6e7dad62c2ee4a3ba8bdcbdffbe46d8b3bd4205 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Mon, 6 Jul 2020 19:04:35 +0000 Subject: [PATCH 32/38] feature/regional_grid This commit references NOAA-EMC#4. Rename c96 regional grid regression test as gfdl regional. Update Dell driver script accordingly. --- reg_tests/grid_gen/c96.uniform.sh | 2 +- reg_tests/grid_gen/driver.dell.sh | 8 ++++---- .../{c96.regional.sh => gfdl.regional.sh} | 20 +++++++++---------- 3 files changed, 15 insertions(+), 15 deletions(-) rename reg_tests/grid_gen/{c96.regional.sh => gfdl.regional.sh} (79%) diff --git a/reg_tests/grid_gen/c96.uniform.sh b/reg_tests/grid_gen/c96.uniform.sh index 61f28009d..d01f5f66d 100755 --- a/reg_tests/grid_gen/c96.uniform.sh +++ b/reg_tests/grid_gen/c96.uniform.sh @@ -35,7 +35,7 @@ echo "Ending at: " `date` # Compare output to baseline set of data. #----------------------------------------------------------------------------- -cd $out_dir +cd $out_dir/C96 test_failed=0 for files in *tile*.nc ./fix_sfc/*tile*.nc diff --git a/reg_tests/grid_gen/driver.dell.sh b/reg_tests/grid_gen/driver.dell.sh index 7ceac48e7..8027b84e3 100755 --- a/reg_tests/grid_gen/driver.dell.sh +++ b/reg_tests/grid_gen/driver.dell.sh @@ -56,15 +56,15 @@ bsub -e $LOG_FILE -o $LOG_FILE -q $QUEUE -P $PROJECT_CODE -J c96.uniform -W 0:15 -R "span[ptile=24]" -R "affinity[core(1):distribute=balance]" "$PWD/c96.uniform.sh" #----------------------------------------------------------------------------- -# C96 regional grid +# GFDL regional grid #----------------------------------------------------------------------------- -bsub -e $LOG_FILE -o $LOG_FILE -q $QUEUE -P $PROJECT_CODE -J c96.regional -W 0:10 -x -n 24 -w 'ended(c96.uniform)' \ - -R "span[ptile=24]" -R "affinity[core(1):distribute=balance]" "$PWD/c96.regional.sh" +bsub -e $LOG_FILE -o $LOG_FILE -q $QUEUE -P $PROJECT_CODE -J gfdl.regional -W 0:10 -x -n 24 -w 'ended(c96.uniform)' \ + -R "span[ptile=24]" -R "affinity[core(1):distribute=balance]" "$PWD/gfdl.regional.sh" #----------------------------------------------------------------------------- # Create summary log. #----------------------------------------------------------------------------- bsub -o $LOG_FILE -q $QUEUE -P $PROJECT_CODE -J summary -R "affinity[core(1)]" -R "rusage[mem=100]" -W 0:01 \ - -w 'ended(c96.regional)' "grep -a '<<<' $LOG_FILE >> $SUM_FILE" + -w 'ended(gfdl.regional)' "grep -a '<<<' $LOG_FILE >> $SUM_FILE" diff --git a/reg_tests/grid_gen/c96.regional.sh b/reg_tests/grid_gen/gfdl.regional.sh similarity index 79% rename from reg_tests/grid_gen/c96.regional.sh rename to reg_tests/grid_gen/gfdl.regional.sh index 39a7e54d4..54fb934d8 100755 --- a/reg_tests/grid_gen/c96.regional.sh +++ b/reg_tests/grid_gen/gfdl.regional.sh @@ -1,18 +1,18 @@ #!/bin/bash #----------------------------------------------------------------------- -# Create a C96 regional grid. Compare output to a set +# Create a regional gfdl grid. Compare output to a set # of baseline files using the 'nccmp' utility. This script is # run by the machine specific driver script. #----------------------------------------------------------------------- set -x -export TMPDIR=${WORK_DIR}/c96.regional.work -export out_dir=${WORK_DIR}/c96.regional +export TMPDIR=${WORK_DIR}/gfdl.regional.work +export out_dir=${WORK_DIR}/gfdl.regional -export res=96 -export gtype=regional +export res=96 # global resolution in which grid is embedded. +export gtype=regional_gfdl export stretch_fac=1.5 # Stretching factor for the grid export target_lon=-97.5 # Center longitude of the highest resolution tile export target_lat=35.5 # Center latitude of the highest resolution tile @@ -34,7 +34,7 @@ $home_dir/ush/fv3gfs_driver_grid.sh iret=$? if [ $iret -ne 0 ]; then set +x - echo "<<< C96 REGIONAL TEST FAILED. <<<" + echo "<<< GFDL REGIONAL TEST FAILED. <<<" exit $iret fi @@ -44,14 +44,14 @@ echo "Ending at: " `date` # Compare output to baseline set of data. #----------------------------------------------------------------------------- -cd $out_dir +cd $out_dir/C424 test_failed=0 for files in *tile*.nc ./fix_sfc/*tile*.nc do if [ -f $files ]; then echo CHECK $files - $NCCMP -dmfqS $files $HOMEreg/c96.regional/$files + $NCCMP -dmfqS $files $HOMEreg/gfdl.regional/$files iret=$? if [ $iret -ne 0 ]; then test_failed=1 @@ -61,9 +61,9 @@ done set +x if [ $test_failed -ne 0 ]; then - echo "<<< C96 REGIONAL TEST FAILED. >>>" + echo "<<< GFDL REGIONAL TEST FAILED. >>>" else - echo "<<< C96 REGIONAL TEST PASSED. >>>" + echo "<<< GFDL REGIONAL TEST PASSED. >>>" fi exit 0 From de872710067c71e64eee0593bf17996e0b732c05 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Mon, 6 Jul 2020 22:05:41 +0000 Subject: [PATCH 33/38] feature/regional_grid This commit references NOAA-EMC#4 Update grid_gen regression test driver scripts. --- reg_tests/grid_gen/driver.cray.sh | 8 ++++---- reg_tests/grid_gen/driver.hera.sh | 6 +++--- reg_tests/grid_gen/driver.jet.sh | 6 +++--- ush/fv3gfs_filter_topo.sh | 2 +- 4 files changed, 11 insertions(+), 11 deletions(-) diff --git a/reg_tests/grid_gen/driver.cray.sh b/reg_tests/grid_gen/driver.cray.sh index 40267adbd..a20ffb093 100755 --- a/reg_tests/grid_gen/driver.cray.sh +++ b/reg_tests/grid_gen/driver.cray.sh @@ -58,16 +58,16 @@ bsub -e $LOG_FILE -o $LOG_FILE -q $QUEUE -P $PROJECT_CODE -J c96.uniform -W 0:15 -extsched 'CRAYLINUX[]' "export NODES=1; $PWD/c96.uniform.sh" #----------------------------------------------------------------------------- -# C96 regional grid +# gfdl regional grid #----------------------------------------------------------------------------- -bsub -e $LOG_FILE -o $LOG_FILE -q $QUEUE -P $PROJECT_CODE -J c96.regional -W 0:10 -M 2400 \ - -w 'ended(c96.uniform)' -extsched 'CRAYLINUX[]' "export NODES=1; $PWD/c96.regional.sh" +bsub -e $LOG_FILE -o $LOG_FILE -q $QUEUE -P $PROJECT_CODE -J gfdl.regional -W 0:10 -M 2400 \ + -w 'ended(c96.uniform)' -extsched 'CRAYLINUX[]' "export NODES=1; $PWD/gfdl.regional.sh" #----------------------------------------------------------------------------- # Create summary log. #----------------------------------------------------------------------------- -bsub -o $LOG_FILE -q $QUEUE -P $PROJECT_CODE -J summary -R "rusage[mem=100]" -W 0:01 -w 'ended(c96.regional)' "grep -a '<<<' $LOG_FILE >> $SUM_FILE" +bsub -o $LOG_FILE -q $QUEUE -P $PROJECT_CODE -J summary -R "rusage[mem=100]" -W 0:01 -w 'ended(gfdl.regional)' "grep -a '<<<' $LOG_FILE >> $SUM_FILE" exit diff --git a/reg_tests/grid_gen/driver.hera.sh b/reg_tests/grid_gen/driver.hera.sh index 3483bfb52..ad19573fd 100755 --- a/reg_tests/grid_gen/driver.hera.sh +++ b/reg_tests/grid_gen/driver.hera.sh @@ -59,11 +59,11 @@ TEST1=$(sbatch --parsable --ntasks-per-node=24 --nodes=1 -t 0:15:00 -A $PROJECT_ -o $LOG_FILE -e $LOG_FILE ./c96.uniform.sh) #----------------------------------------------------------------------------- -# C96 regional grid +# gfdl regional grid #----------------------------------------------------------------------------- -TEST2=$(sbatch --parsable --ntasks-per-node=24 --nodes=1 -t 0:10:00 -A $PROJECT_CODE -q $QUEUE -J c96.regional \ - -o $LOG_FILE -e $LOG_FILE -d afterok:$TEST1 ./c96.regional.sh) +TEST2=$(sbatch --parsable --ntasks-per-node=24 --nodes=1 -t 0:10:00 -A $PROJECT_CODE -q $QUEUE -J gfdl.regional \ + -o $LOG_FILE -e $LOG_FILE -d afterok:$TEST1 ./gfdl.regional.sh) #----------------------------------------------------------------------------- # Create summary log. diff --git a/reg_tests/grid_gen/driver.jet.sh b/reg_tests/grid_gen/driver.jet.sh index 3ec9726a7..a340582b2 100755 --- a/reg_tests/grid_gen/driver.jet.sh +++ b/reg_tests/grid_gen/driver.jet.sh @@ -59,11 +59,11 @@ TEST1=$(sbatch --parsable --ntasks-per-node=24 --nodes=1 -t 0:15:00 -A $PROJECT_ --partition=xjet -o $LOG_FILE -e $LOG_FILE ./c96.uniform.sh) #----------------------------------------------------------------------------- -# C96 regional grid +# gfdl regional grid #----------------------------------------------------------------------------- -TEST2=$(sbatch --parsable --ntasks-per-node=24 --nodes=1 -t 0:10:00 -A $PROJECT_CODE -q $QUEUE -J c96.regional \ - --partition=xjet -o $LOG_FILE -e $LOG_FILE -d afterok:$TEST1 ./c96.regional.sh) +TEST2=$(sbatch --parsable --ntasks-per-node=24 --nodes=1 -t 0:10:00 -A $PROJECT_CODE -q $QUEUE -J gfdl.regional \ + --partition=xjet -o $LOG_FILE -e $LOG_FILE -d afterok:$TEST1 ./gfdl.regional.sh) #----------------------------------------------------------------------------- # Create summary log. diff --git a/ush/fv3gfs_filter_topo.sh b/ush/fv3gfs_filter_topo.sh index 9685d9ad7..4f0b2e8e6 100755 --- a/ush/fv3gfs_filter_topo.sh +++ b/ush/fv3gfs_filter_topo.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/bin/ksh set -ax #----------------------------------------------------------------------------------------- From 09686c2444b4ecd11a6c9e763773665468c35573 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 7 Jul 2020 17:53:45 +0000 Subject: [PATCH 34/38] feature/regional_grid This commit references NOAA-EMC#4 Update driver script comments. --- driver_scripts/driver_grid.cray.sh | 2 +- driver_scripts/driver_grid.dell.sh | 4 ++-- driver_scripts/driver_grid.hera.sh | 2 +- driver_scripts/driver_grid.jet.sh | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/driver_scripts/driver_grid.cray.sh b/driver_scripts/driver_grid.cray.sh index 256b782cd..2fd8465ca 100755 --- a/driver_scripts/driver_grid.cray.sh +++ b/driver_scripts/driver_grid.cray.sh @@ -34,7 +34,7 @@ # "stretch" - global stretched grid # "nest" - global stretched grid with nest # "regional_gfdl" - stand-alone gfdl regional grid -# "regional_esg" - stand-alone extended Schmidt gnominic +# "regional_esg" - stand-alone extended Schmidt gnomonic # (esg) regional grid # 3) For "stretch" and "nest" grids, set the stretching factor - # "stretch_fac", and center lat/lon of highest resolution diff --git a/driver_scripts/driver_grid.dell.sh b/driver_scripts/driver_grid.dell.sh index 0fef8e913..a1d891fe7 100755 --- a/driver_scripts/driver_grid.dell.sh +++ b/driver_scripts/driver_grid.dell.sh @@ -36,7 +36,7 @@ # "stretch" - global stretched grid # "nest" - global stretched grid with nest # "regional_gfdl" - stand-alone gfdl regional grid -# "regional_esg" - stand-alone extended Schmidt gnominic +# "regional_esg" - stand-alone extended Schmidt gnomonic # (esg) regional grid # 3) For "stretch" and "nest" grids, set the stretching factor - # "stretch_fac", and center lat/lon of highest resolution @@ -64,7 +64,7 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export gtype=regional_gfdl # 'uniform', 'stretch', 'nest', +export gtype=uniform # 'uniform', 'stretch', 'nest', # 'regional_gfdl', 'regional_esg' if [ $gtype = uniform ]; then diff --git a/driver_scripts/driver_grid.hera.sh b/driver_scripts/driver_grid.hera.sh index 50007fae3..9852564f5 100755 --- a/driver_scripts/driver_grid.hera.sh +++ b/driver_scripts/driver_grid.hera.sh @@ -34,7 +34,7 @@ # "stretch" - global stretched grid # "nest" - global stretched grid with nest # "regional_gfdl" - stand-alone gfdl regional grid -# "regional_esg" - stand-alone extended Schmidt gnominic +# "regional_esg" - stand-alone extended Schmidt gnomonic # (esg) regional grid # 3) For "stretch" and "nest" grids, set the stretching factor - # "stretch_fac", and center lat/lon of highest resolution diff --git a/driver_scripts/driver_grid.jet.sh b/driver_scripts/driver_grid.jet.sh index b88c2f53c..ca1abea7f 100755 --- a/driver_scripts/driver_grid.jet.sh +++ b/driver_scripts/driver_grid.jet.sh @@ -35,7 +35,7 @@ # "stretch" - global stretched grid # "nest" - global stretched grid with nest # "regional_gfdl" - stand-alone gfdl regional grid -# "regional_esg" - stand-alone extended Schmidt gnominic +# "regional_esg" - stand-alone extended Schmidt gnomonic # (esg) regional grid # 3) For "stretch" and "nest" grids, set the stretching factor - # "stretch_fac", and center lat/lon of highest resolution From 5c7ea82d8ed7798eb4e2f5d6db4fb056a8a7668d Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 8 Jul 2020 13:21:43 +0000 Subject: [PATCH 35/38] feature/regional_grid This commit references NOAA-EMC#4 Remove unused variables from ush/fv3gfs_make_orog.sh. --- ush/fv3gfs_make_orog.sh | 3 --- 1 file changed, 3 deletions(-) diff --git a/ush/fv3gfs_make_orog.sh b/ush/fv3gfs_make_orog.sh index 7a52122fb..532c6407f 100755 --- a/ush/fv3gfs_make_orog.sh +++ b/ush/fv3gfs_make_orog.sh @@ -11,7 +11,6 @@ if [ $nargv -eq 6 ]; then # lat-lon grid export outdir=$3 export script_dir=$4 export is_latlon=1 - export ntiles=1 export orogfile="none" export hist_dir=$5 export TMPDIR=$6 @@ -24,7 +23,6 @@ elif [ $nargv -eq 7 ]; then # cubed-sphere grid export griddir=$3 export outdir=$4 export script_dir=$5 - export ntiles=6 export is_latlon=0 export orogfile="none" export hist_dir=$6 @@ -37,7 +35,6 @@ elif [ $nargv -eq 8 ]; then # input your own orography files export tile=$2 export griddir=$3 export outdir=$4 - export ntiles=6 export is_latlon=0 export inputorog=$5 export script_dir=$6 From 05e10b5bcce805f892a59a1c612b4d30d5178288 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Wed, 8 Jul 2020 15:14:40 +0000 Subject: [PATCH 36/38] feature/regional_grid This commit references NOAA-EMC#4 Add logic to override the default version of ncdump. On Cray, the version associated with the netcdf build module load did not work for the grid generation regression test. Not sure why. --- reg_tests/grid_gen/driver.cray.sh | 1 + ush/fv3gfs_driver_grid.sh | 4 +++- ush/fv3gfs_make_grid.sh | 2 +- 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/reg_tests/grid_gen/driver.cray.sh b/reg_tests/grid_gen/driver.cray.sh index a20ffb093..535ce28f4 100755 --- a/reg_tests/grid_gen/driver.cray.sh +++ b/reg_tests/grid_gen/driver.cray.sh @@ -44,6 +44,7 @@ export machine=WCOSS_C export KMP_AFFINITY=disabled export NCCMP=/gpfs/hps3/emc/global/noscrub/George.Gayno/util/netcdf/nccmp export HOMEreg=/gpfs/hps3/emc/global/noscrub/George.Gayno/ufs_utils.git/reg_tests/grid_gen/baseline_data +export NCDUMP=/gpfs/hps/usrx/local/prod/NetCDF/4.2/intel/sandybridge/bin/ncdump rm -fr $WORK_DIR diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh index 2f4b2985a..dc37d28ff 100755 --- a/ush/fv3gfs_driver_grid.sh +++ b/ush/fv3gfs_driver_grid.sh @@ -96,6 +96,8 @@ export script_dir=$home_dir/ush export exec_dir=$home_dir/exec export topo=$home_dir/fix/fix_orog +export NCDUMP=${NCDUMP:-ncdump} + rm -fr $TMPDIR mkdir -p $TMPDIR cd $TMPDIR ||exit 8 @@ -326,7 +328,7 @@ elif [ $gtype = regional_gfdl ] || [ $gtype = regional_esg ]; then # Redefine resolution for regional grids as a global equivalent resolution. #---------------------------------------------------------------------------------- - res=$( ncdump -h ${grid_dir}/C*_grid.tile7.nc | grep -o ":RES_equiv = [0-9]\+" | grep -o "[0-9]" ) + res=$( $NCDUMP -h ${grid_dir}/C*_grid.tile7.nc | grep -o ":RES_equiv = [0-9]\+" | grep -o "[0-9]" ) res=${res//$'\n'/} out_dir=$out_dir/C${res} mkdir -p $out_dir diff --git a/ush/fv3gfs_make_grid.sh b/ush/fv3gfs_make_grid.sh index d4c6581fd..7a7cff105 100755 --- a/ush/fv3gfs_make_grid.sh +++ b/ush/fv3gfs_make_grid.sh @@ -38,7 +38,7 @@ set -ax function get_res { - res=$( ncdump -h $1 | grep -o ":RES_equiv = [0-9]\+" | grep -o "[0-9]" ) + res=$( $NCDUMP -h $1 | grep -o ":RES_equiv = [0-9]\+" | grep -o "[0-9]" ) res=${res//$'\n'/} } From b8b9842061b9c4e6c37d28aca6d03f7f1144a4b1 Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 14 Jul 2020 13:20:00 +0000 Subject: [PATCH 37/38] feature/regional_grid This commit references NOAA-EMC#4. Per Dusan's recommendation, move filter_topo, global_equiv_resol, regional_esg_grid and shave from fre-nctools.fd to its own directory. fre-nctools.fd should only contain the gfdl tools. --- sorc/CMakeLists.txt | 1 + sorc/fre-nctools.fd/CMakeLists.txt | 4 ---- sorc/grid_tools.fd/CMakeLists.txt | 4 ++++ .../filter_topo.fd}/CMakeLists.txt | 0 .../filter_topo.fd}/filter_topo.F90 | 0 .../global_equiv_resol.fd/CMakeLists.txt | 0 .../global_equiv_resol.fd/global_equiv_resol.f90 | 0 .../regional_esg_grid.fd/CMakeLists.txt | 0 .../tools => grid_tools.fd}/regional_esg_grid.fd/pesg.f90 | 0 .../tools => grid_tools.fd}/regional_esg_grid.fd/pfun.f90 | 0 .../tools => grid_tools.fd}/regional_esg_grid.fd/pietc.f90 | 0 .../tools => grid_tools.fd}/regional_esg_grid.fd/pietc_s.f90 | 0 .../tools => grid_tools.fd}/regional_esg_grid.fd/pkind.f90 | 0 .../tools => grid_tools.fd}/regional_esg_grid.fd/pmat.f90 | 0 .../tools => grid_tools.fd}/regional_esg_grid.fd/pmat2.f90 | 0 .../tools => grid_tools.fd}/regional_esg_grid.fd/pmat4.f90 | 0 .../tools => grid_tools.fd}/regional_esg_grid.fd/pmat5.f90 | 0 .../tools => grid_tools.fd}/regional_esg_grid.fd/psym2.f90 | 0 .../regional_esg_grid.fd/regional_esg_grid.f90 | 0 .../tools => grid_tools.fd}/shave.fd/CMakeLists.txt | 0 .../tools => grid_tools.fd}/shave.fd/shave_nc.F90 | 0 21 files changed, 5 insertions(+), 4 deletions(-) create mode 100644 sorc/grid_tools.fd/CMakeLists.txt rename sorc/{fre-nctools.fd/tools/filter_topo => grid_tools.fd/filter_topo.fd}/CMakeLists.txt (100%) rename sorc/{fre-nctools.fd/tools/filter_topo => grid_tools.fd/filter_topo.fd}/filter_topo.F90 (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/global_equiv_resol.fd/CMakeLists.txt (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/global_equiv_resol.fd/global_equiv_resol.f90 (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/regional_esg_grid.fd/CMakeLists.txt (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/regional_esg_grid.fd/pesg.f90 (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/regional_esg_grid.fd/pfun.f90 (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/regional_esg_grid.fd/pietc.f90 (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/regional_esg_grid.fd/pietc_s.f90 (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/regional_esg_grid.fd/pkind.f90 (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/regional_esg_grid.fd/pmat.f90 (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/regional_esg_grid.fd/pmat2.f90 (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/regional_esg_grid.fd/pmat4.f90 (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/regional_esg_grid.fd/pmat5.f90 (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/regional_esg_grid.fd/psym2.f90 (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/regional_esg_grid.fd/regional_esg_grid.f90 (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/shave.fd/CMakeLists.txt (100%) rename sorc/{fre-nctools.fd/tools => grid_tools.fd}/shave.fd/shave_nc.F90 (100%) diff --git a/sorc/CMakeLists.txt b/sorc/CMakeLists.txt index b5c8884ef..fbf3ce95c 100644 --- a/sorc/CMakeLists.txt +++ b/sorc/CMakeLists.txt @@ -13,6 +13,7 @@ add_subdirectory(nemsio_get.fd) add_subdirectory(nemsio_chgdate.fd) add_subdirectory(mkgfsnemsioctl.fd) add_subdirectory(fre-nctools.fd) +add_subdirectory(grid_tools.fd) add_subdirectory(chgres_cube.fd) add_subdirectory(orog.fd) add_subdirectory(sfc_climo_gen.fd) diff --git a/sorc/fre-nctools.fd/CMakeLists.txt b/sorc/fre-nctools.fd/CMakeLists.txt index 353c4fb7c..66f79bfef 100644 --- a/sorc/fre-nctools.fd/CMakeLists.txt +++ b/sorc/fre-nctools.fd/CMakeLists.txt @@ -2,7 +2,3 @@ add_subdirectory(shared_lib) add_subdirectory(tools/fregrid) add_subdirectory(tools/make_solo_mosaic) add_subdirectory(tools/make_hgrid) -add_subdirectory(tools/filter_topo) -add_subdirectory(tools/shave.fd) -add_subdirectory(tools/global_equiv_resol.fd) -add_subdirectory(tools/regional_esg_grid.fd) diff --git a/sorc/grid_tools.fd/CMakeLists.txt b/sorc/grid_tools.fd/CMakeLists.txt new file mode 100644 index 000000000..a4e66910c --- /dev/null +++ b/sorc/grid_tools.fd/CMakeLists.txt @@ -0,0 +1,4 @@ +add_subdirectory(shave.fd) +add_subdirectory(filter_topo.fd) +add_subdirectory(regional_esg_grid.fd) +add_subdirectory(global_equiv_resol.fd) diff --git a/sorc/fre-nctools.fd/tools/filter_topo/CMakeLists.txt b/sorc/grid_tools.fd/filter_topo.fd/CMakeLists.txt similarity index 100% rename from sorc/fre-nctools.fd/tools/filter_topo/CMakeLists.txt rename to sorc/grid_tools.fd/filter_topo.fd/CMakeLists.txt diff --git a/sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 b/sorc/grid_tools.fd/filter_topo.fd/filter_topo.F90 similarity index 100% rename from sorc/fre-nctools.fd/tools/filter_topo/filter_topo.F90 rename to sorc/grid_tools.fd/filter_topo.fd/filter_topo.F90 diff --git a/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/CMakeLists.txt b/sorc/grid_tools.fd/global_equiv_resol.fd/CMakeLists.txt similarity index 100% rename from sorc/fre-nctools.fd/tools/global_equiv_resol.fd/CMakeLists.txt rename to sorc/grid_tools.fd/global_equiv_resol.fd/CMakeLists.txt diff --git a/sorc/fre-nctools.fd/tools/global_equiv_resol.fd/global_equiv_resol.f90 b/sorc/grid_tools.fd/global_equiv_resol.fd/global_equiv_resol.f90 similarity index 100% rename from sorc/fre-nctools.fd/tools/global_equiv_resol.fd/global_equiv_resol.f90 rename to sorc/grid_tools.fd/global_equiv_resol.fd/global_equiv_resol.f90 diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/CMakeLists.txt b/sorc/grid_tools.fd/regional_esg_grid.fd/CMakeLists.txt similarity index 100% rename from sorc/fre-nctools.fd/tools/regional_esg_grid.fd/CMakeLists.txt rename to sorc/grid_tools.fd/regional_esg_grid.fd/CMakeLists.txt diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pesg.f90 b/sorc/grid_tools.fd/regional_esg_grid.fd/pesg.f90 similarity index 100% rename from sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pesg.f90 rename to sorc/grid_tools.fd/regional_esg_grid.fd/pesg.f90 diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pfun.f90 b/sorc/grid_tools.fd/regional_esg_grid.fd/pfun.f90 similarity index 100% rename from sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pfun.f90 rename to sorc/grid_tools.fd/regional_esg_grid.fd/pfun.f90 diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pietc.f90 b/sorc/grid_tools.fd/regional_esg_grid.fd/pietc.f90 similarity index 100% rename from sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pietc.f90 rename to sorc/grid_tools.fd/regional_esg_grid.fd/pietc.f90 diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pietc_s.f90 b/sorc/grid_tools.fd/regional_esg_grid.fd/pietc_s.f90 similarity index 100% rename from sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pietc_s.f90 rename to sorc/grid_tools.fd/regional_esg_grid.fd/pietc_s.f90 diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pkind.f90 b/sorc/grid_tools.fd/regional_esg_grid.fd/pkind.f90 similarity index 100% rename from sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pkind.f90 rename to sorc/grid_tools.fd/regional_esg_grid.fd/pkind.f90 diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat.f90 b/sorc/grid_tools.fd/regional_esg_grid.fd/pmat.f90 similarity index 100% rename from sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat.f90 rename to sorc/grid_tools.fd/regional_esg_grid.fd/pmat.f90 diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat2.f90 b/sorc/grid_tools.fd/regional_esg_grid.fd/pmat2.f90 similarity index 100% rename from sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat2.f90 rename to sorc/grid_tools.fd/regional_esg_grid.fd/pmat2.f90 diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat4.f90 b/sorc/grid_tools.fd/regional_esg_grid.fd/pmat4.f90 similarity index 100% rename from sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat4.f90 rename to sorc/grid_tools.fd/regional_esg_grid.fd/pmat4.f90 diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat5.f90 b/sorc/grid_tools.fd/regional_esg_grid.fd/pmat5.f90 similarity index 100% rename from sorc/fre-nctools.fd/tools/regional_esg_grid.fd/pmat5.f90 rename to sorc/grid_tools.fd/regional_esg_grid.fd/pmat5.f90 diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/psym2.f90 b/sorc/grid_tools.fd/regional_esg_grid.fd/psym2.f90 similarity index 100% rename from sorc/fre-nctools.fd/tools/regional_esg_grid.fd/psym2.f90 rename to sorc/grid_tools.fd/regional_esg_grid.fd/psym2.f90 diff --git a/sorc/fre-nctools.fd/tools/regional_esg_grid.fd/regional_esg_grid.f90 b/sorc/grid_tools.fd/regional_esg_grid.fd/regional_esg_grid.f90 similarity index 100% rename from sorc/fre-nctools.fd/tools/regional_esg_grid.fd/regional_esg_grid.f90 rename to sorc/grid_tools.fd/regional_esg_grid.fd/regional_esg_grid.f90 diff --git a/sorc/fre-nctools.fd/tools/shave.fd/CMakeLists.txt b/sorc/grid_tools.fd/shave.fd/CMakeLists.txt similarity index 100% rename from sorc/fre-nctools.fd/tools/shave.fd/CMakeLists.txt rename to sorc/grid_tools.fd/shave.fd/CMakeLists.txt diff --git a/sorc/fre-nctools.fd/tools/shave.fd/shave_nc.F90 b/sorc/grid_tools.fd/shave.fd/shave_nc.F90 similarity index 100% rename from sorc/fre-nctools.fd/tools/shave.fd/shave_nc.F90 rename to sorc/grid_tools.fd/shave.fd/shave_nc.F90 From 5b7754316988cf5ffcdfe46f3edc8701be18f4fd Mon Sep 17 00:00:00 2001 From: George Gayno Date: Tue, 28 Jul 2020 14:30:48 +0000 Subject: [PATCH 38/38] feature/regional_grid This commit references NOAA-EMC#4 Update default grid to 'uniform' in driver scripts. --- driver_scripts/driver_grid.cray.sh | 2 +- driver_scripts/driver_grid.hera.sh | 2 +- driver_scripts/driver_grid.jet.sh | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/driver_scripts/driver_grid.cray.sh b/driver_scripts/driver_grid.cray.sh index 2fd8465ca..2abe26f72 100755 --- a/driver_scripts/driver_grid.cray.sh +++ b/driver_scripts/driver_grid.cray.sh @@ -62,7 +62,7 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export gtype=regional_esg # 'uniform', 'stretch', 'nest' +export gtype=uniform # 'uniform', 'stretch', 'nest' # 'regional_gfdl', 'regional_esg' if [ $gtype = uniform ]; then diff --git a/driver_scripts/driver_grid.hera.sh b/driver_scripts/driver_grid.hera.sh index 9852564f5..50f13fbee 100755 --- a/driver_scripts/driver_grid.hera.sh +++ b/driver_scripts/driver_grid.hera.sh @@ -64,7 +64,7 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export gtype=regional_esg # 'uniform', 'stretch', 'nest' +export gtype=uniform # 'uniform', 'stretch', 'nest' # 'regional_gfdl', 'regional_esg' if [ $gtype = uniform ]; then diff --git a/driver_scripts/driver_grid.jet.sh b/driver_scripts/driver_grid.jet.sh index ca1abea7f..179864abd 100755 --- a/driver_scripts/driver_grid.jet.sh +++ b/driver_scripts/driver_grid.jet.sh @@ -65,7 +65,7 @@ module list # Set grid specs here. #----------------------------------------------------------------------- -export gtype=regional_esg # 'uniform', 'stretch', 'nest' +export gtype=uniform # 'uniform', 'stretch', 'nest' # 'regional_gfdl', 'regional_esg' if [ $gtype = uniform ]; then