From 9555b543f74c4b88d6a9c416a71693265426cfbb Mon Sep 17 00:00:00 2001 From: Alex Richert Date: Tue, 5 Mar 2024 13:38:43 -0800 Subject: [PATCH] try --whitespace 0 --- src/bicubic_interp_mod.F90 | 708 +++++----- src/bilinear_interp_mod.F90 | 644 ++++----- src/budget_interp_mod.F90 | 922 ++++++------- src/earth_radius_mod.F90 | 94 +- src/gdswzd_c.F90 | 94 +- src/gdswzd_mod.F90 | 466 +++---- src/ip_constants_mod.F90 | 14 +- src/ip_equid_cylind_grid_mod.F90 | 420 +++--- src/ip_gaussian_grid_mod.F90 | 504 +++---- src/ip_grid_descriptor_mod.F90 | 120 +- src/ip_grid_factory_mod.F90 | 134 +- src/ip_grid_mod.F90 | 188 +-- src/ip_grids_mod.F90 | 2 +- src/ip_interpolators_mod.F90 | 14 +- src/ip_lambert_conf_grid_mod.F90 | 460 +++---- src/ip_mercator_grid_mod.F90 | 346 ++--- src/ip_mod.F90 | 14 +- src/ip_polar_stereo_grid_mod.F90 | 612 ++++----- src/ip_rot_equid_cylind_egrid_mod.F90 | 640 ++++----- src/ip_rot_equid_cylind_grid_mod.F90 | 612 ++++----- src/ip_station_points_grid_mod.F90 | 52 +- src/ipolates.F90 | 342 ++--- src/ipolatev.F90 | 430 +++--- src/ipxetas.F90 | 170 +-- src/ipxwafs.F90 | 226 ++-- src/ipxwafs2.F90 | 260 ++-- src/ipxwafs3.F90 | 296 ++--- src/movect.F90 | 60 +- src/neighbor_budget_interp_mod.F90 | 560 ++++---- src/neighbor_interp_mod.F90 | 600 ++++----- src/polfix_mod.F90 | 274 ++-- src/spectral_interp_mod.F90 | 1736 ++++++++++++------------- 32 files changed, 6007 insertions(+), 6007 deletions(-) diff --git a/src/bicubic_interp_mod.F90 b/src/bicubic_interp_mod.F90 index 6aa35aec..d9c495aa 100644 --- a/src/bicubic_interp_mod.F90 +++ b/src/bicubic_interp_mod.F90 @@ -17,10 +17,10 @@ module bicubic_interp_mod interface interpolate_bicubic module procedure interpolate_bicubic_scalar module procedure interpolate_bicubic_vector - end interface interpolate_bicubic + endinterface interpolate_bicubic ! Smallest positive real value (use for equality comparisons) - real :: tinyreal = tiny(1.0) + real :: tinyreal=tiny(1.0) contains @@ -77,206 +77,206 @@ module bicubic_interp_mod !> - 3 unrecognized output grid !> !> @author George Gayno, Mark Iredell, Kyle Gerheiser, Eric Engle - subroutine interpolate_bicubic_scalar(ipopt, grid_in, grid_out, & - mi, mo, km, ibi, li, gi, & - no, rlat, rlon, ibo, lo, go, iret) - class(ip_grid), intent(in) :: grid_in, grid_out - integer, intent(in) :: ipopt(20) - integer, intent(in) :: mi, mo, km - integer, intent(in) :: ibi(km) - integer, intent(inout) :: no - integer, intent(out) :: iret, ibo(km) + subroutine interpolate_bicubic_scalar(ipopt,grid_in,grid_out, & + mi,mo,km,ibi,li,gi, & + no,rlat,rlon,ibo,lo,go,iret) + class(ip_grid),intent(in) :: grid_in,grid_out + integer,intent(in) :: ipopt(20) + integer,intent(in) :: mi,mo,km + integer,intent(in) :: ibi(km) + integer,intent(inout) :: no + integer,intent(out) :: iret,ibo(km) ! - logical*1, intent(in) :: li(mi, km) - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(in) :: li(mi,km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: gi(mi, km) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: go(mo, km) + real,intent(in) :: gi(mi,km) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: go(mo,km) ! - real, parameter :: fill = -9999. + real,parameter :: fill=-9999. ! - integer :: ijx(4), ijy(4) - integer :: mcon, mp, n, i, j, k - integer :: nk, nv - logical :: same_gridi, same_grido + integer :: ijx(4),ijy(4) + integer :: mcon,mp,n,i,j,k + integer :: nk,nv + logical :: same_gridi,same_grido ! - real :: pmp, xij, yij, xf, yf - real :: g, w, gmin, gmax - real :: wx(4), wy(4) - real :: xpts(mo), ypts(mo) + real :: pmp,xij,yij,xf,yf + real :: g,w,gmin,gmax + real :: wx(4),wy(4) + real :: xpts(mo),ypts(mo) logical :: to_station_points ! Save coeffecients between calls and only compute if grids have changed - real, allocatable, save :: rlatx(:), rlonx(:) - real, allocatable, save :: wxy(:, :, :) - integer, save :: nox = -1, iretx = -1 - integer, allocatable, save :: nxy(:, :, :), nc(:) - class(ip_grid), allocatable, save :: prev_grid_in, prev_grid_out + real,allocatable,save :: rlatx(:),rlonx(:) + real,allocatable,save :: wxy(:,:,:) + integer,save :: nox=-1,iretx=-1 + integer,allocatable,save :: nxy(:,:,:),nc(:) + class(ip_grid),allocatable,save :: prev_grid_in,prev_grid_out ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SET PARAMETERS - iret = 0 - mcon = ipopt(1) - mp = ipopt(2) - if (mp .eq. -1 .or. mp .eq. 0) mp = 50 - if (mp .lt. 0 .or. mp .gt. 100) iret = 32 - pmp = mp*0.01 + iret=0 + mcon=ipopt(1) + mp=ipopt(2) + if(mp.eq.-1.or.mp.eq.0) mp=50 + if(mp.lt.0.or.mp.gt.100) iret=32 + pmp=mp*0.01 - if (.not. allocated(prev_grid_in) .or. .not. allocated(prev_grid_out)) then - allocate (prev_grid_in, source=grid_in) - allocate (prev_grid_out, source=grid_out) + if(.not.allocated(prev_grid_in).or..not.allocated(prev_grid_out)) then + allocate(prev_grid_in,source=grid_in) + allocate(prev_grid_out,source=grid_out) - same_gridi = .false. - same_grido = .false. + same_gridi=.false. + same_grido=.false. else - same_gridi = grid_in .eq. prev_grid_in - same_grido = grid_out .eq. prev_grid_out + same_gridi=grid_in.eq.prev_grid_in + same_grido=grid_out.eq.prev_grid_out - if (.not. same_gridi .or. .not. same_grido) then - deallocate (prev_grid_in) - deallocate (prev_grid_out) + if(.not.same_gridi.or..not.same_grido) then + deallocate(prev_grid_in) + deallocate(prev_grid_out) - allocate (prev_grid_in, source=grid_in) - allocate (prev_grid_out, source=grid_out) - end if - end if + allocate(prev_grid_in,source=grid_in) + allocate(prev_grid_out,source=grid_out) + endif + endif - select type (grid_out) - type is (ip_station_points_grid) - to_station_points = .true. + select type(grid_out) + type is(ip_station_points_grid) + to_station_points=.true. class default - to_station_points = .false. - end select + to_station_points=.false. + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SAVE OR SKIP WEIGHT COMPUTATION - if (iret .eq. 0 .and. (to_station_points .or. .not. same_gridi .or. .not. same_grido)) then + if(iret.eq.0.and.(to_station_points.or..not.same_gridi.or..not.same_grido)) then ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES. - call gdswzd(grid_out, 0, mo, fill, xpts, ypts, rlon, rlat, no) - if (no .eq. 0) iret = 3 + call gdswzd(grid_out,0,mo,fill,xpts,ypts,rlon,rlat,no) + if(no.eq.0) iret=3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! LOCATE INPUT POINTS - call gdswzd(grid_in, -1, no, fill, xpts, ypts, rlon, rlat, nv) - if (iret .eq. 0 .and. nv .eq. 0) iret = 2 + call gdswzd(grid_in,-1,no,fill,xpts,ypts,rlon,rlat,nv) + if(iret.eq.0.and.nv.eq.0) iret=2 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! ALLOCATE AND SAVE GRID DATA - if (nox .ne. no) then - if (nox .ge. 0) deallocate (rlatx, rlonx, nc, nxy, wxy) - allocate (rlatx(no), rlonx(no), nc(no), nxy(4, 4, no), wxy(4, 4, no)) - nox = no - end if - iretx = iret + if(nox.ne.no) then + if(nox.ge.0) deallocate(rlatx,rlonx,nc,nxy,wxy) + allocate(rlatx(no),rlonx(no),nc(no),nxy(4,4,no),wxy(4,4,no)) + nox=no + endif + iretx=iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE WEIGHTS - if (iret .eq. 0) then - !$omp parallel do private(n, xij, yij, ijx, ijy, xf, yf, j, i, wx, wy) schedule(static) - do n = 1, no - rlonx(n) = rlon(n) - rlatx(n) = rlat(n) - xij = xpts(n) - yij = ypts(n) - if (abs(xij-fill) .gt. tinyreal .and. abs(yij-fill) .gt. tinyreal) then - ijx(1:4) = floor(xij-1)+(/0, 1, 2, 3/) - ijy(1:4) = floor(yij-1)+(/0, 1, 2, 3/) - xf = xij-ijx(2) - yf = yij-ijy(2) - do j = 1, 4 - do i = 1, 4 - nxy(i, j, n) = grid_in%field_pos(ijx(i), ijy(j)) - end do - end do - if (minval(nxy(1:4, 1:4, n)) .gt. 0) then + if(iret.eq.0) then + !$omp parallel do private(n,xij,yij,ijx,ijy,xf,yf,j,i,wx,wy) schedule(static) + do n=1,no + rlonx(n)=rlon(n) + rlatx(n)=rlat(n) + xij=xpts(n) + yij=ypts(n) + if(abs(xij-fill).gt.tinyreal.and.abs(yij-fill).gt.tinyreal) then + ijx(1:4)=floor(xij-1)+(/0,1,2,3/) + ijy(1:4)=floor(yij-1)+(/0,1,2,3/) + xf=xij-ijx(2) + yf=yij-ijy(2) + do j=1,4 + do i=1,4 + nxy(i,j,n)=grid_in%field_pos(ijx(i),ijy(j)) + enddo + enddo + if(minval(nxy(1:4,1:4,n)).gt.0) then ! BICUBIC WHERE 16-POINT STENCIL IS AVAILABLE - nc(n) = 1 - wx(1) = xf*(1-xf)*(2-xf)/(-6.) - wx(2) = (xf+1)*(1-xf)*(2-xf)/2. - wx(3) = (xf+1)*xf*(2-xf)/2. - wx(4) = (xf+1)*xf*(1-xf)/(-6.) - wy(1) = yf*(1-yf)*(2-yf)/(-6.) - wy(2) = (yf+1)*(1-yf)*(2-yf)/2. - wy(3) = (yf+1)*yf*(2-yf)/2. - wy(4) = (yf+1)*yf*(1-yf)/(-6.) + nc(n)=1 + wx(1)=xf*(1-xf)*(2-xf)/(-6.) + wx(2)=(xf+1)*(1-xf)*(2-xf)/2. + wx(3)=(xf+1)*xf*(2-xf)/2. + wx(4)=(xf+1)*xf*(1-xf)/(-6.) + wy(1)=yf*(1-yf)*(2-yf)/(-6.) + wy(2)=(yf+1)*(1-yf)*(2-yf)/2. + wy(3)=(yf+1)*yf*(2-yf)/2. + wy(4)=(yf+1)*yf*(1-yf)/(-6.) else ! BILINEAR ELSEWHERE NEAR THE EDGE OF THE GRID - nc(n) = 2 - wx(1) = 0 - wx(2) = (1-xf) - wx(3) = xf - wx(4) = 0 - wy(1) = 0 - wy(2) = (1-yf) - wy(3) = yf - wy(4) = 0 - end if - do j = 1, 4 - do i = 1, 4 - wxy(i, j, n) = wx(i)*wy(j) - end do - end do + nc(n)=2 + wx(1)=0 + wx(2)=(1-xf) + wx(3)=xf + wx(4)=0 + wy(1)=0 + wy(2)=(1-yf) + wy(3)=yf + wy(4)=0 + endif + do j=1,4 + do i=1,4 + wxy(i,j,n)=wx(i)*wy(j) + enddo + enddo else - nc(n) = 0 - end if - end do - end if - end if + nc(n)=0 + endif + enddo + endif + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE OVER ALL FIELDS - if (iret .eq. 0 .and. iretx .eq. 0) then - if (.not. to_station_points) then - no = nox - do n = 1, no - rlon(n) = rlonx(n) - rlat(n) = rlatx(n) - end do - end if - !$omp parallel do private(nk, k, n, g, w, gmin, gmax, j, i) schedule(static) - do nk = 1, no*km - k = (nk-1)/no+1 - n = nk-no*(k-1) - if (nc(n) .gt. 0) then - g = 0 - w = 0 - if (mcon .gt. 0) gmin = huge(gmin) - if (mcon .gt. 0) gmax = -huge(gmax) - do j = nc(n), 5-nc(n) - do i = nc(n), 5-nc(n) - if (nxy(i, j, n) .gt. 0) then - if (ibi(k) .eq. 0 .or. li(nxy(i, j, n), k)) then - g = g+wxy(i, j, n)*gi(nxy(i, j, n), k) - w = w+wxy(i, j, n) - if (mcon .gt. 0) gmin = min(gmin, gi(nxy(i, j, n), k)) - if (mcon .gt. 0) gmax = max(gmax, gi(nxy(i, j, n), k)) - end if - end if - end do - end do - lo(n, k) = w .ge. pmp - if (lo(n, k)) then - go(n, k) = g/w - if (mcon .gt. 0) go(n, k) = min(max(go(n, k), gmin), gmax) + if(iret.eq.0.and.iretx.eq.0) then + if(.not.to_station_points) then + no=nox + do n=1,no + rlon(n)=rlonx(n) + rlat(n)=rlatx(n) + enddo + endif + !$omp parallel do private(nk,k,n,g,w,gmin,gmax,j,i) schedule(static) + do nk=1,no*km + k=(nk-1)/no+1 + n=nk-no*(k-1) + if(nc(n).gt.0) then + g=0 + w=0 + if(mcon.gt.0) gmin=huge(gmin) + if(mcon.gt.0) gmax=-huge(gmax) + do j=nc(n),5-nc(n) + do i=nc(n),5-nc(n) + if(nxy(i,j,n).gt.0) then + if(ibi(k).eq.0.or.li(nxy(i,j,n),k)) then + g=g+wxy(i,j,n)*gi(nxy(i,j,n),k) + w=w+wxy(i,j,n) + if(mcon.gt.0) gmin=min(gmin,gi(nxy(i,j,n),k)) + if(mcon.gt.0) gmax=max(gmax,gi(nxy(i,j,n),k)) + endif + endif + enddo + enddo + lo(n,k)=w.ge.pmp + if(lo(n,k)) then + go(n,k)=g/w + if(mcon.gt.0) go(n,k)=min(max(go(n,k),gmin),gmax) else - go(n, k) = 0. - end if + go(n,k)=0. + endif else - lo(n, k) = .false. - go(n, k) = 0. - end if - end do - do k = 1, km - ibo(k) = ibi(k) - if (.not. all(lo(1:no, k))) ibo(k) = 1 - end do - select type (grid_out) - type is (ip_equid_cylind_grid) - call polfixs(no, mo, km, rlat, ibo, lo, go) - end select + lo(n,k)=.false. + go(n,k)=0. + endif + enddo + do k=1,km + ibo(k)=ibi(k) + if(.not.all(lo(1:no,k))) ibo(k)=1 + enddo + select type(grid_out) + type is(ip_equid_cylind_grid) + call polfixs(no,mo,km,rlat,ibo,lo,go) + endselect else - if (iret .eq. 0) iret = iretx - if (.not. to_station_points) no = 0 - end if - end subroutine interpolate_bicubic_scalar + if(iret.eq.0) iret=iretx + if(.not.to_station_points) no=0 + endif + endsubroutine interpolate_bicubic_scalar !> This subprogram performs bicubic interpolation from any grid to !> any grid for vector fields. @@ -335,235 +335,235 @@ end subroutine interpolate_bicubic_scalar !> - 3 unrecognized output grid !> !> @author George Gayno, Mark Iredell, Kyle Gerheiser, Eric Engle - subroutine interpolate_bicubic_vector(ipopt, grid_in, grid_out, & - mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - class(ip_grid), intent(in) :: grid_in, grid_out - integer, intent(in) :: ipopt(20) - integer, intent(in) :: ibi(km), mi, mo, km - integer, intent(inout) :: no - integer, intent(out) :: iret, ibo(km) + subroutine interpolate_bicubic_vector(ipopt,grid_in,grid_out, & + mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + class(ip_grid),intent(in) :: grid_in,grid_out + integer,intent(in) :: ipopt(20) + integer,intent(in) :: ibi(km),mi,mo,km + integer,intent(inout) :: no + integer,intent(out) :: iret,ibo(km) ! - logical*1, intent(in) :: li(mi, km) - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(in) :: li(mi,km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: ui(mi, km), vi(mi, km) - real, intent(inout) :: rlat(mo), rlon(mo), crot(mo), srot(mo) - real, intent(out) :: uo(mo, km), vo(mo, km) + real,intent(in) :: ui(mi,km),vi(mi,km) + real,intent(inout) :: rlat(mo),rlon(mo),crot(mo),srot(mo) + real,intent(out) :: uo(mo,km),vo(mo,km) ! - real, parameter :: fill = -9999. + real,parameter :: fill=-9999. ! - integer :: ijx(4), ijy(4) - integer :: mcon, mp, n, i, j, k, nk, nv + integer :: ijx(4),ijy(4) + integer :: mcon,mp,n,i,j,k,nk,nv ! - logical :: same_gridi, same_grido + logical :: same_gridi,same_grido ! - real :: cm, sm, urot, vrot - real :: pmp, xij, yij, xf, yf - real :: u, v, w, umin, umax, vmin, vmax - real :: xpts(mo), ypts(mo) - real :: wx(4), wy(4) - real :: xpti(mi), ypti(mi), rloi(mi), rlai(mi) - real :: croi(mi), sroi(mi) + real :: cm,sm,urot,vrot + real :: pmp,xij,yij,xf,yf + real :: u,v,w,umin,umax,vmin,vmax + real :: xpts(mo),ypts(mo) + real :: wx(4),wy(4) + real :: xpti(mi),ypti(mi),rloi(mi),rlai(mi) + real :: croi(mi),sroi(mi) logical :: to_station_points ! Save coeffecients between calls and only compute if grids have changed - real, allocatable, save :: rlatx(:), rlonx(:), crotx(:), srotx(:) - real, allocatable, save :: wxy(:, :, :), cxy(:, :, :), sxy(:, :, :) - integer, save :: nox = -1, iretx = -1 - integer, allocatable, save :: nxy(:, :, :), nc(:) - class(ip_grid), allocatable, save :: prev_grid_in, prev_grid_out + real,allocatable,save :: rlatx(:),rlonx(:),crotx(:),srotx(:) + real,allocatable,save :: wxy(:,:,:),cxy(:,:,:),sxy(:,:,:) + integer,save :: nox=-1,iretx=-1 + integer,allocatable,save :: nxy(:,:,:),nc(:) + class(ip_grid),allocatable,save :: prev_grid_in,prev_grid_out ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SET PARAMETERS - iret = 0 - mcon = ipopt(1) - mp = ipopt(2) - if (mp .eq. -1 .or. mp .eq. 0) mp = 50 - if (mp .lt. 0 .or. mp .gt. 100) iret = 32 - pmp = mp*0.01 + iret=0 + mcon=ipopt(1) + mp=ipopt(2) + if(mp.eq.-1.or.mp.eq.0) mp=50 + if(mp.lt.0.or.mp.gt.100) iret=32 + pmp=mp*0.01 - if (.not. allocated(prev_grid_in) .or. .not. allocated(prev_grid_out)) then - allocate (prev_grid_in, source=grid_in) - allocate (prev_grid_out, source=grid_out) + if(.not.allocated(prev_grid_in).or..not.allocated(prev_grid_out)) then + allocate(prev_grid_in,source=grid_in) + allocate(prev_grid_out,source=grid_out) - same_gridi = .false. - same_grido = .false. + same_gridi=.false. + same_grido=.false. else - same_gridi = grid_in .eq. prev_grid_in - same_grido = grid_out .eq. prev_grid_out + same_gridi=grid_in.eq.prev_grid_in + same_grido=grid_out.eq.prev_grid_out - if (.not. same_gridi .or. .not. same_grido) then - deallocate (prev_grid_in) - deallocate (prev_grid_out) + if(.not.same_gridi.or..not.same_grido) then + deallocate(prev_grid_in) + deallocate(prev_grid_out) - allocate (prev_grid_in, source=grid_in) - allocate (prev_grid_out, source=grid_out) - end if - end if + allocate(prev_grid_in,source=grid_in) + allocate(prev_grid_out,source=grid_out) + endif + endif - select type (grid_out) - type is (ip_station_points_grid) - to_station_points = .true. + select type(grid_out) + type is(ip_station_points_grid) + to_station_points=.true. class default - to_station_points = .false. - end select + to_station_points=.false. + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SAVE OR SKIP WEIGHT COMPUTATION - if (iret .eq. 0 .and. (to_station_points .or. .not. same_gridi .or. .not. same_grido)) then + if(iret.eq.0.and.(to_station_points.or..not.same_gridi.or..not.same_grido)) then ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES. - call gdswzd(grid_out, 0, mo, fill, xpts, ypts, rlon, rlat, no, crot, srot) - if (no .eq. 0) iret = 3 + call gdswzd(grid_out,0,mo,fill,xpts,ypts,rlon,rlat,no,crot,srot) + if(no.eq.0) iret=3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! LOCATE INPUT POINTS - call gdswzd(grid_in, -1, no, fill, xpts, ypts, rlon, rlat, nv) - if (iret .eq. 0 .and. nv .eq. 0) iret = 2 - call gdswzd(grid_in, 0, mi, fill, xpti, ypti, rloi, rlai, nv, croi, sroi) + call gdswzd(grid_in,-1,no,fill,xpts,ypts,rlon,rlat,nv) + if(iret.eq.0.and.nv.eq.0) iret=2 + call gdswzd(grid_in,0,mi,fill,xpti,ypti,rloi,rlai,nv,croi,sroi) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! ALLOCATE AND SAVE GRID DATA - if (nox .ne. no) then - if (nox .ge. 0) deallocate (rlatx, rlonx, crotx, srotx, nc, nxy, wxy, cxy, sxy) - allocate (rlatx(no), rlonx(no), crotx(no), srotx(no), nc(no), & - nxy(4, 4, no), wxy(4, 4, no), cxy(4, 4, no), sxy(4, 4, no)) - nox = no - end if - iretx = iret + if(nox.ne.no) then + if(nox.ge.0) deallocate(rlatx,rlonx,crotx,srotx,nc,nxy,wxy,cxy,sxy) + allocate(rlatx(no),rlonx(no),crotx(no),srotx(no),nc(no), & + nxy(4,4,no),wxy(4,4,no),cxy(4,4,no),sxy(4,4,no)) + nox=no + endif + iretx=iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE WEIGHTS - if (iret .eq. 0) then - !$omp parallel do private(n, xij, yij, ijx, ijy, xf, yf, j, i, wx, wy, cm, sm) schedule(static) - do n = 1, no - rlonx(n) = rlon(n) - rlatx(n) = rlat(n) - crotx(n) = crot(n) - srotx(n) = srot(n) - xij = xpts(n) - yij = ypts(n) - if (abs(xij-fill) .gt. tinyreal .and. abs(yij-fill) .gt. tinyreal) then - ijx(1:4) = floor(xij-1)+(/0, 1, 2, 3/) - ijy(1:4) = floor(yij-1)+(/0, 1, 2, 3/) - xf = xij-ijx(2) - yf = yij-ijy(2) - do j = 1, 4 - do i = 1, 4 - nxy(i, j, n) = grid_in%field_pos(ijx(i), ijy(j)) - end do - end do - if (minval(nxy(1:4, 1:4, n)) .gt. 0) then + if(iret.eq.0) then + !$omp parallel do private(n,xij,yij,ijx,ijy,xf,yf,j,i,wx,wy,cm,sm) schedule(static) + do n=1,no + rlonx(n)=rlon(n) + rlatx(n)=rlat(n) + crotx(n)=crot(n) + srotx(n)=srot(n) + xij=xpts(n) + yij=ypts(n) + if(abs(xij-fill).gt.tinyreal.and.abs(yij-fill).gt.tinyreal) then + ijx(1:4)=floor(xij-1)+(/0,1,2,3/) + ijy(1:4)=floor(yij-1)+(/0,1,2,3/) + xf=xij-ijx(2) + yf=yij-ijy(2) + do j=1,4 + do i=1,4 + nxy(i,j,n)=grid_in%field_pos(ijx(i),ijy(j)) + enddo + enddo + if(minval(nxy(1:4,1:4,n)).gt.0) then ! BICUBIC WHERE 16-POINT STENCIL IS AVAILABLE - nc(n) = 1 - wx(1) = xf*(1-xf)*(2-xf)/(-6.) - wx(2) = (xf+1)*(1-xf)*(2-xf)/2. - wx(3) = (xf+1)*xf*(2-xf)/2. - wx(4) = (xf+1)*xf*(1-xf)/(-6.) - wy(1) = yf*(1-yf)*(2-yf)/(-6.) - wy(2) = (yf+1)*(1-yf)*(2-yf)/2. - wy(3) = (yf+1)*yf*(2-yf)/2. - wy(4) = (yf+1)*yf*(1-yf)/(-6.) + nc(n)=1 + wx(1)=xf*(1-xf)*(2-xf)/(-6.) + wx(2)=(xf+1)*(1-xf)*(2-xf)/2. + wx(3)=(xf+1)*xf*(2-xf)/2. + wx(4)=(xf+1)*xf*(1-xf)/(-6.) + wy(1)=yf*(1-yf)*(2-yf)/(-6.) + wy(2)=(yf+1)*(1-yf)*(2-yf)/2. + wy(3)=(yf+1)*yf*(2-yf)/2. + wy(4)=(yf+1)*yf*(1-yf)/(-6.) else ! BILINEAR ELSEWHERE NEAR THE EDGE OF THE GRID - nc(n) = 2 - wx(1) = 0 - wx(2) = (1-xf) - wx(3) = xf - wx(4) = 0 - wy(1) = 0 - wy(2) = (1-yf) - wy(3) = yf - wy(4) = 0 - end if - do j = 1, 4 - do i = 1, 4 - wxy(i, j, n) = wx(i)*wy(j) - if (nxy(i, j, n) .gt. 0) then - call movect(rlai(nxy(i, j, n)), rloi(nxy(i, j, n)), & - rlat(n), rlon(n), cm, sm) - cxy(i, j, n) = cm*croi(nxy(i, j, n))+sm*sroi(nxy(i, j, n)) - sxy(i, j, n) = sm*croi(nxy(i, j, n))-cm*sroi(nxy(i, j, n)) - end if - end do - end do + nc(n)=2 + wx(1)=0 + wx(2)=(1-xf) + wx(3)=xf + wx(4)=0 + wy(1)=0 + wy(2)=(1-yf) + wy(3)=yf + wy(4)=0 + endif + do j=1,4 + do i=1,4 + wxy(i,j,n)=wx(i)*wy(j) + if(nxy(i,j,n).gt.0) then + call movect(rlai(nxy(i,j,n)),rloi(nxy(i,j,n)), & + rlat(n),rlon(n),cm,sm) + cxy(i,j,n)=cm*croi(nxy(i,j,n))+sm*sroi(nxy(i,j,n)) + sxy(i,j,n)=sm*croi(nxy(i,j,n))-cm*sroi(nxy(i,j,n)) + endif + enddo + enddo else - nc(n) = 0 - end if - end do - end if - end if + nc(n)=0 + endif + enddo + endif + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE OVER ALL FIELDS - if (iret .eq. 0 .and. iretx .eq. 0) then - if (.not. to_station_points) then - no = nox - do n = 1, no - rlon(n) = rlonx(n) - rlat(n) = rlatx(n) - crot(n) = crotx(n) - srot(n) = srotx(n) - end do - end if - !$omp parallel do private(nk, k, n, u, v, w, umin, umax, vmin, vmax, urot, vrot, j, i) schedule(static) - do nk = 1, no*km - k = (nk-1)/no+1 - n = nk-no*(k-1) - if (nc(n) .gt. 0) then - u = 0 - v = 0 - w = 0 - if (mcon .gt. 0) umin = huge(umin) - if (mcon .gt. 0) umax = -huge(umax) - if (mcon .gt. 0) vmin = huge(vmin) - if (mcon .gt. 0) vmax = -huge(vmax) - do j = nc(n), 5-nc(n) - do i = nc(n), 5-nc(n) - if (nxy(i, j, n) .gt. 0) then - if (ibi(k) .eq. 0 .or. li(nxy(i, j, n), k)) then - urot = cxy(i, j, n)*ui(nxy(i, j, n), k)-sxy(i, j, n)*vi(nxy(i, j, n), k) - vrot = sxy(i, j, n)*ui(nxy(i, j, n), k)+cxy(i, j, n)*vi(nxy(i, j, n), k) - u = u+wxy(i, j, n)*urot - v = v+wxy(i, j, n)*vrot - w = w+wxy(i, j, n) - if (mcon .gt. 0) umin = min(umin, urot) - if (mcon .gt. 0) umax = max(umax, urot) - if (mcon .gt. 0) vmin = min(vmin, vrot) - if (mcon .gt. 0) vmax = max(vmax, vrot) - end if - end if - end do - end do - lo(n, k) = w .ge. pmp - if (lo(n, k)) then - urot = crot(n)*u-srot(n)*v - vrot = srot(n)*u+crot(n)*v - uo(n, k) = urot/w - vo(n, k) = vrot/w - if (mcon .gt. 0) uo(n, k) = min(max(uo(n, k), umin), umax) - if (mcon .gt. 0) vo(n, k) = min(max(vo(n, k), vmin), vmax) + if(iret.eq.0.and.iretx.eq.0) then + if(.not.to_station_points) then + no=nox + do n=1,no + rlon(n)=rlonx(n) + rlat(n)=rlatx(n) + crot(n)=crotx(n) + srot(n)=srotx(n) + enddo + endif + !$omp parallel do private(nk,k,n,u,v,w,umin,umax,vmin,vmax,urot,vrot,j,i) schedule(static) + do nk=1,no*km + k=(nk-1)/no+1 + n=nk-no*(k-1) + if(nc(n).gt.0) then + u=0 + v=0 + w=0 + if(mcon.gt.0) umin=huge(umin) + if(mcon.gt.0) umax=-huge(umax) + if(mcon.gt.0) vmin=huge(vmin) + if(mcon.gt.0) vmax=-huge(vmax) + do j=nc(n),5-nc(n) + do i=nc(n),5-nc(n) + if(nxy(i,j,n).gt.0) then + if(ibi(k).eq.0.or.li(nxy(i,j,n),k)) then + urot=cxy(i,j,n)*ui(nxy(i,j,n),k)-sxy(i,j,n)*vi(nxy(i,j,n),k) + vrot=sxy(i,j,n)*ui(nxy(i,j,n),k)+cxy(i,j,n)*vi(nxy(i,j,n),k) + u=u+wxy(i,j,n)*urot + v=v+wxy(i,j,n)*vrot + w=w+wxy(i,j,n) + if(mcon.gt.0) umin=min(umin,urot) + if(mcon.gt.0) umax=max(umax,urot) + if(mcon.gt.0) vmin=min(vmin,vrot) + if(mcon.gt.0) vmax=max(vmax,vrot) + endif + endif + enddo + enddo + lo(n,k)=w.ge.pmp + if(lo(n,k)) then + urot=crot(n)*u-srot(n)*v + vrot=srot(n)*u+crot(n)*v + uo(n,k)=urot/w + vo(n,k)=vrot/w + if(mcon.gt.0) uo(n,k)=min(max(uo(n,k),umin),umax) + if(mcon.gt.0) vo(n,k)=min(max(vo(n,k),vmin),vmax) else - uo(n, k) = 0. - vo(n, k) = 0. - end if + uo(n,k)=0. + vo(n,k)=0. + endif else - lo(n, k) = .false. - uo(n, k) = 0. - vo(n, k) = 0. - end if - end do - do k = 1, km - ibo(k) = ibi(k) - if (.not. all(lo(1:no, k))) ibo(k) = 1 - end do - select type (grid_out) - type is (ip_equid_cylind_grid) - call polfixv(no, mo, km, rlat, rlon, ibo, lo, uo, vo) - end select + lo(n,k)=.false. + uo(n,k)=0. + vo(n,k)=0. + endif + enddo + do k=1,km + ibo(k)=ibi(k) + if(.not.all(lo(1:no,k))) ibo(k)=1 + enddo + select type(grid_out) + type is(ip_equid_cylind_grid) + call polfixv(no,mo,km,rlat,rlon,ibo,lo,uo,vo) + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else - if (iret .eq. 0) iret = iretx - if (.not. to_station_points) no = 0 - end if + if(iret.eq.0) iret=iretx + if(.not.to_station_points) no=0 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine interpolate_bicubic_vector + endsubroutine interpolate_bicubic_vector -end module bicubic_interp_mod +endmodule bicubic_interp_mod diff --git a/src/bilinear_interp_mod.F90 b/src/bilinear_interp_mod.F90 index e403570e..cbffd704 100644 --- a/src/bilinear_interp_mod.F90 +++ b/src/bilinear_interp_mod.F90 @@ -19,10 +19,10 @@ module bilinear_interp_mod interface interpolate_bilinear module procedure interpolate_bilinear_scalar module procedure interpolate_bilinear_vector - end interface interpolate_bilinear + endinterface interpolate_bilinear ! Smallest positive real value (use for equality comparisons) - real :: tinyreal = tiny(1.0) + real :: tinyreal=tiny(1.0) contains @@ -69,210 +69,210 @@ module bilinear_interp_mod !> - 3 unrecognized output grid !> !> @author George Gayno, Mark Iredell, Kyle Gerheiser, Eric Engle - subroutine interpolate_bilinear_scalar(ipopt, grid_in, grid_out, mi, mo, km, ibi, li, gi, no, rlat, rlon, ibo, lo, go, iret) - class(ip_grid), intent(in) :: grid_in, grid_out - integer, intent(in) :: ipopt(20) - integer, intent(in) :: mi, mo, km - integer, intent(in) :: ibi(km) - integer, intent(inout) :: no - integer, intent(out) :: iret, ibo(km) + subroutine interpolate_bilinear_scalar(ipopt,grid_in,grid_out,mi,mo,km,ibi,li,gi,no,rlat,rlon,ibo,lo,go,iret) + class(ip_grid),intent(in) :: grid_in,grid_out + integer,intent(in) :: ipopt(20) + integer,intent(in) :: mi,mo,km + integer,intent(in) :: ibi(km) + integer,intent(inout) :: no + integer,intent(out) :: iret,ibo(km) ! - logical*1, intent(in) :: li(mi, km) - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(in) :: li(mi,km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: gi(mi, km) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: go(mo, km) + real,intent(in) :: gi(mi,km) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: go(mo,km) ! - real, parameter :: fill = -9999. + real,parameter :: fill=-9999. ! - integer :: ijx(2), ijy(2) - integer :: mp, n, i, j, k - integer :: nk, nv - integer :: mspiral, i1, j1, ixs, jxs - integer :: mx, kxs, kxt, ix, jx, nx + integer :: ijx(2),ijy(2) + integer :: mp,n,i,j,k + integer :: nk,nv + integer :: mspiral,i1,j1,ixs,jxs + integer :: mx,kxs,kxt,ix,jx,nx ! - logical :: same_gridi, same_grido + logical :: same_gridi,same_grido ! - real :: wx(2), wy(2) - real :: xpts(mo), ypts(mo) - real :: pmp, xij, yij, xf, yf, g, w + real :: wx(2),wy(2) + real :: xpts(mo),ypts(mo) + real :: pmp,xij,yij,xf,yf,g,w logical :: to_station_points ! Save coeffecients between calls and only compute if grids have changed - integer, save :: nox = -1, iretx = -1 - integer, allocatable, save :: nxy(:, :, :) - real, allocatable, save :: rlatx(:), rlonx(:) - real, allocatable, save :: wxy(:, :, :) - class(ip_grid), allocatable, save :: prev_grid_in, prev_grid_out + integer,save :: nox=-1,iretx=-1 + integer,allocatable,save :: nxy(:,:,:) + real,allocatable,save :: rlatx(:),rlonx(:) + real,allocatable,save :: wxy(:,:,:) + class(ip_grid),allocatable,save :: prev_grid_in,prev_grid_out - iret = 0 - mp = ipopt(1) - if (mp .eq. -1 .or. mp .eq. 0) mp = 50 - if (mp .lt. 0 .or. mp .gt. 100) iret = 32 - pmp = mp*0.01 - mspiral = max(ipopt(2), 0) + iret=0 + mp=ipopt(1) + if(mp.eq.-1.or.mp.eq.0) mp=50 + if(mp.lt.0.or.mp.gt.100) iret=32 + pmp=mp*0.01 + mspiral=max(ipopt(2),0) - if (.not. allocated(prev_grid_in) .or. .not. allocated(prev_grid_out)) then - allocate (prev_grid_in, source=grid_in) - allocate (prev_grid_out, source=grid_out) + if(.not.allocated(prev_grid_in).or..not.allocated(prev_grid_out)) then + allocate(prev_grid_in,source=grid_in) + allocate(prev_grid_out,source=grid_out) - same_gridi = .false. - same_grido = .false. + same_gridi=.false. + same_grido=.false. else - same_gridi = grid_in .eq. prev_grid_in - same_grido = grid_out .eq. prev_grid_out + same_gridi=grid_in.eq.prev_grid_in + same_grido=grid_out.eq.prev_grid_out - if (.not. same_gridi .or. .not. same_grido) then - deallocate (prev_grid_in) - deallocate (prev_grid_out) + if(.not.same_gridi.or..not.same_grido) then + deallocate(prev_grid_in) + deallocate(prev_grid_out) - allocate (prev_grid_in, source=grid_in) - allocate (prev_grid_out, source=grid_out) - end if - end if + allocate(prev_grid_in,source=grid_in) + allocate(prev_grid_out,source=grid_out) + endif + endif - select type (grid_out) - type is (ip_station_points_grid) - to_station_points = .true. + select type(grid_out) + type is(ip_station_points_grid) + to_station_points=.true. class default - to_station_points = .false. - end select + to_station_points=.false. + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SAVE OR SKIP WEIGHT COMPUTATION - if (iret .eq. 0 .and. (to_station_points .or. .not. same_gridi .or. .not. same_grido)) then + if(iret.eq.0.and.(to_station_points.or..not.same_gridi.or..not.same_grido)) then ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES. - call gdswzd(grid_out, 0, mo, fill, xpts, ypts, rlon, rlat, no) - if (no .eq. 0) iret = 3 + call gdswzd(grid_out,0,mo,fill,xpts,ypts,rlon,rlat,no) + if(no.eq.0) iret=3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! LOCATE INPUT POINTS - call gdswzd(grid_in, -1, no, fill, xpts, ypts, rlon, rlat, nv) - if (iret .eq. 0 .and. nv .eq. 0) iret = 2 + call gdswzd(grid_in,-1,no,fill,xpts,ypts,rlon,rlat,nv) + if(iret.eq.0.and.nv.eq.0) iret=2 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! ALLOCATE AND SAVE GRID DATA - if (nox .ne. no) then - if (nox .ge. 0) deallocate (rlatx, rlonx, nxy, wxy) - allocate (rlatx(no), rlonx(no), nxy(2, 2, no), wxy(2, 2, no)) - nox = no - end if - iretx = iret + if(nox.ne.no) then + if(nox.ge.0) deallocate(rlatx,rlonx,nxy,wxy) + allocate(rlatx(no),rlonx(no),nxy(2,2,no),wxy(2,2,no)) + nox=no + endif + iretx=iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE WEIGHTS - if (iret .eq. 0) then - !$omp parallel do private(n, xij, yij, ijx, ijy, xf, yf, j, i, wx, wy) schedule(static) - do n = 1, no - rlonx(n) = rlon(n) - rlatx(n) = rlat(n) - xij = xpts(n) - yij = ypts(n) - if (abs(xij-fill) .gt. tinyreal .and. abs(yij-fill) .gt. tinyreal) then - ijx(1:2) = floor(xij)+(/0, 1/) - ijy(1:2) = floor(yij)+(/0, 1/) - xf = xij-ijx(1) - yf = yij-ijy(1) - wx(1) = (1-xf) - wx(2) = xf - wy(1) = (1-yf) - wy(2) = yf - do j = 1, 2 - do i = 1, 2 - nxy(i, j, n) = grid_in%field_pos(ijx(i), ijy(j)) - wxy(i, j, n) = wx(i)*wy(j) - end do - end do + if(iret.eq.0) then + !$omp parallel do private(n,xij,yij,ijx,ijy,xf,yf,j,i,wx,wy) schedule(static) + do n=1,no + rlonx(n)=rlon(n) + rlatx(n)=rlat(n) + xij=xpts(n) + yij=ypts(n) + if(abs(xij-fill).gt.tinyreal.and.abs(yij-fill).gt.tinyreal) then + ijx(1:2)=floor(xij)+(/0,1/) + ijy(1:2)=floor(yij)+(/0,1/) + xf=xij-ijx(1) + yf=yij-ijy(1) + wx(1)=(1-xf) + wx(2)=xf + wy(1)=(1-yf) + wy(2)=yf + do j=1,2 + do i=1,2 + nxy(i,j,n)=grid_in%field_pos(ijx(i),ijy(j)) + wxy(i,j,n)=wx(i)*wy(j) + enddo + enddo else - nxy(:, :, n) = 0 - end if - end do - end if - end if + nxy(:,:,n)=0 + endif + enddo + endif + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE OVER ALL FIELDS - if (iret .eq. 0 .and. iretx .eq. 0) then - if (.not. to_station_points) then - no = nox - do n = 1, no - rlon(n) = rlonx(n) - rlat(n) = rlatx(n) - end do - end if + if(iret.eq.0.and.iretx.eq.0) then + if(.not.to_station_points) then + no=nox + do n=1,no + rlon(n)=rlonx(n) + rlat(n)=rlatx(n) + enddo + endif !$omp parallel do & - !$omp private(nk, k, n, g, w, j, i) & - !$omp private(i1, j1, ixs, jxs, mx, kxs, kxt, ix, jx, nx) schedule(static) - do nk = 1, no*km - k = (nk-1)/no+1 - n = nk-no*(k-1) - g = 0 - w = 0 - do j = 1, 2 - do i = 1, 2 - if (nxy(i, j, n) .gt. 0) then - if (ibi(k) .eq. 0 .or. li(nxy(i, j, n), k)) then - g = g+wxy(i, j, n)*gi(nxy(i, j, n), k) - w = w+wxy(i, j, n) - end if - end if - end do - end do - lo(n, k) = w .ge. pmp - if (lo(n, k)) then - go(n, k) = g/w - elseif (mspiral .gt. 0 .and. abs(xpts(n)-fill) .gt. tinyreal .and. abs(ypts(n)-fill) .gt. tinyreal) then - i1 = nint(xpts(n)) - j1 = nint(ypts(n)) - ixs = int(sign(1., xpts(n)-i1)) - jxs = int(sign(1., ypts(n)-j1)) - spiral: do mx = 1, mspiral**2 - kxs = int(sqrt(4*mx-2.5)) - kxt = mx-(kxs**2/4+1) - select case (mod(kxs, 4)) - case (1) - ix = i1-ixs*(kxs/4-kxt) - jx = j1-jxs*kxs/4 - case (2) - ix = i1+ixs*(1+kxs/4) - jx = j1-jxs*(kxs/4-kxt) - case (3) - ix = i1+ixs*(1+kxs/4-kxt) - jx = j1+jxs*(1+kxs/4) + !$omp private(nk,k,n,g,w,j,i) & + !$omp private(i1,j1,ixs,jxs,mx,kxs,kxt,ix,jx,nx) schedule(static) + do nk=1,no*km + k=(nk-1)/no+1 + n=nk-no*(k-1) + g=0 + w=0 + do j=1,2 + do i=1,2 + if(nxy(i,j,n).gt.0) then + if(ibi(k).eq.0.or.li(nxy(i,j,n),k)) then + g=g+wxy(i,j,n)*gi(nxy(i,j,n),k) + w=w+wxy(i,j,n) + endif + endif + enddo + enddo + lo(n,k)=w.ge.pmp + if(lo(n,k)) then + go(n,k)=g/w + elseif(mspiral.gt.0.and.abs(xpts(n)-fill).gt.tinyreal.and.abs(ypts(n)-fill).gt.tinyreal) then + i1=nint(xpts(n)) + j1=nint(ypts(n)) + ixs=int(sign(1.,xpts(n)-i1)) + jxs=int(sign(1.,ypts(n)-j1)) + spiral: do mx=1,mspiral**2 + kxs=int(sqrt(4*mx-2.5)) + kxt=mx-(kxs**2/4+1) + select case(mod(kxs,4)) + case(1) + ix=i1-ixs*(kxs/4-kxt) + jx=j1-jxs*kxs/4 + case(2) + ix=i1+ixs*(1+kxs/4) + jx=j1-jxs*(kxs/4-kxt) + case(3) + ix=i1+ixs*(1+kxs/4-kxt) + jx=j1+jxs*(1+kxs/4) case default - ix = i1-ixs*kxs/4 - jx = j1+jxs*(kxs/4-kxt) - end select - nx = grid_in%field_pos(ix, jx) - if (nx .gt. 0.) then - if (li(nx, k) .or. ibi(k) .eq. 0) then - go(n, k) = gi(nx, k) - lo(n, k) = .true. + ix=i1-ixs*kxs/4 + jx=j1+jxs*(kxs/4-kxt) + endselect + nx=grid_in%field_pos(ix,jx) + if(nx.gt.0.) then + if(li(nx,k).or.ibi(k).eq.0) then + go(n,k)=gi(nx,k) + lo(n,k)=.true. exit spiral - end if - end if - end do spiral - if (.not. lo(n, k)) then - ibo(k) = 1 - go(n, k) = 0. - end if + endif + endif + enddo spiral + if(.not.lo(n,k)) then + ibo(k)=1 + go(n,k)=0. + endif else - go(n, k) = 0. - end if - end do - do k = 1, km - ibo(k) = ibi(k) - if (.not. all(lo(1:no, k))) ibo(k) = 1 - end do - select type (grid_out) - type is (ip_equid_cylind_grid) - call polfixs(no, mo, km, rlat, ibo, lo, go) - end select + go(n,k)=0. + endif + enddo + do k=1,km + ibo(k)=ibi(k) + if(.not.all(lo(1:no,k))) ibo(k)=1 + enddo + select type(grid_out) + type is(ip_equid_cylind_grid) + call polfixs(no,mo,km,rlat,ibo,lo,go) + endselect else - if (iret .eq. 0) iret = iretx - if (.not. to_station_points) no = 0 - end if + if(iret.eq.0) iret=iretx + if(.not.to_station_points) no=0 + endif - end subroutine interpolate_bilinear_scalar + endsubroutine interpolate_bilinear_scalar !> This subprogram performs bilinear interpolation from any grid to !> any grid for vector fields. @@ -326,197 +326,197 @@ end subroutine interpolate_bilinear_scalar !> - 3 unrecognized output grid !> !> @author George Gayno, Mark Iredell, Kyle Gerheiser, Eric Engle - subroutine interpolate_bilinear_vector(ipopt, grid_in, grid_out, & - mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - class(ip_grid), intent(in) :: grid_in, grid_out - integer, intent(in) :: ipopt(20), ibi(km), mi, mo, km - integer, intent(inout) :: no - integer, intent(out) :: iret, ibo(km) + subroutine interpolate_bilinear_vector(ipopt,grid_in,grid_out, & + mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + class(ip_grid),intent(in) :: grid_in,grid_out + integer,intent(in) :: ipopt(20),ibi(km),mi,mo,km + integer,intent(inout) :: no + integer,intent(out) :: iret,ibo(km) ! - logical*1, intent(in) :: li(mi, km) - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(in) :: li(mi,km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: ui(mi, km), vi(mi, km) - real, intent(inout) :: rlat(mo), rlon(mo), crot(mo), srot(mo) - real, intent(out) :: uo(mo, km), vo(mo, km) + real,intent(in) :: ui(mi,km),vi(mi,km) + real,intent(inout) :: rlat(mo),rlon(mo),crot(mo),srot(mo) + real,intent(out) :: uo(mo,km),vo(mo,km) ! - real, parameter :: fill = -9999. + real,parameter :: fill=-9999. ! - integer :: ijx(2), ijy(2) - integer :: mp, n, i, j, k, nk, nv + integer :: ijx(2),ijy(2) + integer :: mp,n,i,j,k,nk,nv ! - logical :: same_gridi, same_grido + logical :: same_gridi,same_grido ! - real :: cm, sm, urot, vrot - real :: pmp, xij, yij, xf, yf, u, v, w - real :: xpts(mo), ypts(mo) - real :: wx(2), wy(2) - real :: xpti(mi), ypti(mi) - real :: rloi(mi), rlai(mi) - real :: croi(mi), sroi(mi) + real :: cm,sm,urot,vrot + real :: pmp,xij,yij,xf,yf,u,v,w + real :: xpts(mo),ypts(mo) + real :: wx(2),wy(2) + real :: xpti(mi),ypti(mi) + real :: rloi(mi),rlai(mi) + real :: croi(mi),sroi(mi) logical :: to_station_points ! Save coeffecients between calls and only compute if grids have changed - integer, save :: nox = -1, iretx = -1 - integer, allocatable, save :: nxy(:, :, :) - real, allocatable, save :: rlatx(:), rlonx(:) - real, allocatable, save :: crotx(:), srotx(:) - real, allocatable, save :: wxy(:, :, :), cxy(:, :, :), sxy(:, :, :) - class(ip_grid), allocatable, save :: prev_grid_in, prev_grid_out + integer,save :: nox=-1,iretx=-1 + integer,allocatable,save :: nxy(:,:,:) + real,allocatable,save :: rlatx(:),rlonx(:) + real,allocatable,save :: crotx(:),srotx(:) + real,allocatable,save :: wxy(:,:,:),cxy(:,:,:),sxy(:,:,:) + class(ip_grid),allocatable,save :: prev_grid_in,prev_grid_out ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SET PARAMETERS - iret = 0 - mp = ipopt(1) - if (mp .eq. -1 .or. mp .eq. 0) mp = 50 - if (mp .lt. 0 .or. mp .gt. 100) iret = 32 - pmp = mp*0.01 + iret=0 + mp=ipopt(1) + if(mp.eq.-1.or.mp.eq.0) mp=50 + if(mp.lt.0.or.mp.gt.100) iret=32 + pmp=mp*0.01 - if (.not. allocated(prev_grid_in) .or. .not. allocated(prev_grid_out)) then - allocate (prev_grid_in, source=grid_in) - allocate (prev_grid_out, source=grid_out) + if(.not.allocated(prev_grid_in).or..not.allocated(prev_grid_out)) then + allocate(prev_grid_in,source=grid_in) + allocate(prev_grid_out,source=grid_out) - same_gridi = .false. - same_grido = .false. + same_gridi=.false. + same_grido=.false. else - same_gridi = grid_in .eq. prev_grid_in - same_grido = grid_out .eq. prev_grid_out + same_gridi=grid_in.eq.prev_grid_in + same_grido=grid_out.eq.prev_grid_out - if (.not. same_gridi .or. .not. same_grido) then - deallocate (prev_grid_in) - deallocate (prev_grid_out) + if(.not.same_gridi.or..not.same_grido) then + deallocate(prev_grid_in) + deallocate(prev_grid_out) - allocate (prev_grid_in, source=grid_in) - allocate (prev_grid_out, source=grid_out) - end if - end if + allocate(prev_grid_in,source=grid_in) + allocate(prev_grid_out,source=grid_out) + endif + endif - select type (grid_out) - type is (ip_station_points_grid) - to_station_points = .true. + select type(grid_out) + type is(ip_station_points_grid) + to_station_points=.true. class default - to_station_points = .false. - end select + to_station_points=.false. + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SAVE OR SKIP WEIGHT COMPUTATION - if (iret .eq. 0 .and. (to_station_points .or. .not. same_gridi .or. .not. same_grido)) then + if(iret.eq.0.and.(to_station_points.or..not.same_gridi.or..not.same_grido)) then ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES. - call gdswzd(grid_out, 0, mo, fill, xpts, ypts, rlon, rlat, no, crot, srot) - if (no .eq. 0) iret = 3 + call gdswzd(grid_out,0,mo,fill,xpts,ypts,rlon,rlat,no,crot,srot) + if(no.eq.0) iret=3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! LOCATE INPUT POINTS - call gdswzd(grid_in, -1, no, fill, xpts, ypts, rlon, rlat, nv) - if (iret .eq. 0 .and. nv .eq. 0) iret = 2 - call gdswzd(grid_in, 0, mi, fill, xpti, ypti, rloi, rlai, nv, croi, sroi) + call gdswzd(grid_in,-1,no,fill,xpts,ypts,rlon,rlat,nv) + if(iret.eq.0.and.nv.eq.0) iret=2 + call gdswzd(grid_in,0,mi,fill,xpti,ypti,rloi,rlai,nv,croi,sroi) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! ALLOCATE AND SAVE GRID DATA - if (nox .ne. no) then - if (nox .ge. 0) deallocate (rlatx, rlonx, crotx, srotx, nxy, wxy, cxy, sxy) - allocate (rlatx(no), rlonx(no), crotx(no), srotx(no), & - nxy(2, 2, no), wxy(2, 2, no), cxy(2, 2, no), sxy(2, 2, no)) - nox = no - end if - iretx = iret + if(nox.ne.no) then + if(nox.ge.0) deallocate(rlatx,rlonx,crotx,srotx,nxy,wxy,cxy,sxy) + allocate(rlatx(no),rlonx(no),crotx(no),srotx(no), & + nxy(2,2,no),wxy(2,2,no),cxy(2,2,no),sxy(2,2,no)) + nox=no + endif + iretx=iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE WEIGHTS - if (iret .eq. 0) then - !$omp parallel do private(n, xij, yij, ijx, ijy, xf, yf, j, i, wx, wy, cm, sm) schedule(static) - do n = 1, no - rlonx(n) = rlon(n) - rlatx(n) = rlat(n) - crotx(n) = crot(n) - srotx(n) = srot(n) - xij = xpts(n) - yij = ypts(n) - if (abs(xij-fill) .gt. tinyreal .and. abs(yij-fill) .gt. tinyreal) then - ijx(1:2) = floor(xij)+(/0, 1/) - ijy(1:2) = floor(yij)+(/0, 1/) - xf = xij-ijx(1) - yf = yij-ijy(1) - wx(1) = (1-xf) - wx(2) = xf - wy(1) = (1-yf) - wy(2) = yf - do j = 1, 2 - do i = 1, 2 - nxy(i, j, n) = grid_in%field_pos(ijx(i), ijy(j)) - wxy(i, j, n) = wx(i)*wy(j) - if (nxy(i, j, n) .gt. 0) then - call movect(rlai(nxy(i, j, n)), rloi(nxy(i, j, n)), & - rlat(n), rlon(n), cm, sm) - cxy(i, j, n) = cm*croi(nxy(i, j, n))+sm*sroi(nxy(i, j, n)) - sxy(i, j, n) = sm*croi(nxy(i, j, n))-cm*sroi(nxy(i, j, n)) - end if - end do - end do + if(iret.eq.0) then + !$omp parallel do private(n,xij,yij,ijx,ijy,xf,yf,j,i,wx,wy,cm,sm) schedule(static) + do n=1,no + rlonx(n)=rlon(n) + rlatx(n)=rlat(n) + crotx(n)=crot(n) + srotx(n)=srot(n) + xij=xpts(n) + yij=ypts(n) + if(abs(xij-fill).gt.tinyreal.and.abs(yij-fill).gt.tinyreal) then + ijx(1:2)=floor(xij)+(/0,1/) + ijy(1:2)=floor(yij)+(/0,1/) + xf=xij-ijx(1) + yf=yij-ijy(1) + wx(1)=(1-xf) + wx(2)=xf + wy(1)=(1-yf) + wy(2)=yf + do j=1,2 + do i=1,2 + nxy(i,j,n)=grid_in%field_pos(ijx(i),ijy(j)) + wxy(i,j,n)=wx(i)*wy(j) + if(nxy(i,j,n).gt.0) then + call movect(rlai(nxy(i,j,n)),rloi(nxy(i,j,n)), & + rlat(n),rlon(n),cm,sm) + cxy(i,j,n)=cm*croi(nxy(i,j,n))+sm*sroi(nxy(i,j,n)) + sxy(i,j,n)=sm*croi(nxy(i,j,n))-cm*sroi(nxy(i,j,n)) + endif + enddo + enddo else - nxy(:, :, n) = 0 - end if - end do - end if ! IS IRET 0? - end if + nxy(:,:,n)=0 + endif + enddo + endif ! IS IRET 0? + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE OVER ALL FIELDS - if (iret .eq. 0 .and. iretx .eq. 0) then - if (.not. to_station_points) then - no = nox - do n = 1, no - rlon(n) = rlonx(n) - rlat(n) = rlatx(n) - crot(n) = crotx(n) - srot(n) = srotx(n) - end do - end if - !$omp parallel do private(nk, k, n, u, v, w, urot, vrot, j, i) schedule(static) - do nk = 1, no*km - k = (nk-1)/no+1 - n = nk-no*(k-1) - u = 0 - v = 0 - w = 0 - do j = 1, 2 - do i = 1, 2 - if (nxy(i, j, n) .gt. 0) then - if (ibi(k) .eq. 0 .or. li(nxy(i, j, n), k)) then - urot = cxy(i, j, n)*ui(nxy(i, j, n), k)-sxy(i, j, n)*vi(nxy(i, j, n), k) - vrot = sxy(i, j, n)*ui(nxy(i, j, n), k)+cxy(i, j, n)*vi(nxy(i, j, n), k) - u = u+wxy(i, j, n)*urot - v = v+wxy(i, j, n)*vrot - w = w+wxy(i, j, n) - end if - end if - end do - end do - lo(n, k) = w .ge. pmp - if (lo(n, k)) then - urot = crot(n)*u-srot(n)*v - vrot = srot(n)*u+crot(n)*v - uo(n, k) = urot/w - vo(n, k) = vrot/w + if(iret.eq.0.and.iretx.eq.0) then + if(.not.to_station_points) then + no=nox + do n=1,no + rlon(n)=rlonx(n) + rlat(n)=rlatx(n) + crot(n)=crotx(n) + srot(n)=srotx(n) + enddo + endif + !$omp parallel do private(nk,k,n,u,v,w,urot,vrot,j,i) schedule(static) + do nk=1,no*km + k=(nk-1)/no+1 + n=nk-no*(k-1) + u=0 + v=0 + w=0 + do j=1,2 + do i=1,2 + if(nxy(i,j,n).gt.0) then + if(ibi(k).eq.0.or.li(nxy(i,j,n),k)) then + urot=cxy(i,j,n)*ui(nxy(i,j,n),k)-sxy(i,j,n)*vi(nxy(i,j,n),k) + vrot=sxy(i,j,n)*ui(nxy(i,j,n),k)+cxy(i,j,n)*vi(nxy(i,j,n),k) + u=u+wxy(i,j,n)*urot + v=v+wxy(i,j,n)*vrot + w=w+wxy(i,j,n) + endif + endif + enddo + enddo + lo(n,k)=w.ge.pmp + if(lo(n,k)) then + urot=crot(n)*u-srot(n)*v + vrot=srot(n)*u+crot(n)*v + uo(n,k)=urot/w + vo(n,k)=vrot/w else - uo(n, k) = 0. - vo(n, k) = 0. - end if - end do ! NK LOOP - do k = 1, km - ibo(k) = ibi(k) - if (.not. all(lo(1:no, k))) ibo(k) = 1 - end do + uo(n,k)=0. + vo(n,k)=0. + endif + enddo ! NK LOOP + do k=1,km + ibo(k)=ibi(k) + if(.not.all(lo(1:no,k))) ibo(k)=1 + enddo - select type (grid_out) - type is (ip_equid_cylind_grid) - call polfixv(no, mo, km, rlat, rlon, ibo, lo, uo, vo) - end select + select type(grid_out) + type is(ip_equid_cylind_grid) + call polfixv(no,mo,km,rlat,rlon,ibo,lo,uo,vo) + endselect else - if (iret .eq. 0) iret = iretx - if (.not. to_station_points) no = 0 - end if + if(iret.eq.0) iret=iretx + if(.not.to_station_points) no=0 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine interpolate_bilinear_vector + endsubroutine interpolate_bilinear_vector -end module bilinear_interp_mod +endmodule bilinear_interp_mod diff --git a/src/budget_interp_mod.F90 b/src/budget_interp_mod.F90 index b74df8c5..731e2b0e 100644 --- a/src/budget_interp_mod.F90 +++ b/src/budget_interp_mod.F90 @@ -21,10 +21,10 @@ module budget_interp_mod interface interpolate_budget module procedure interpolate_budget_scalar module procedure interpolate_budget_vector - end interface interpolate_budget + endinterface interpolate_budget ! Smallest positive real value (use for equality comparisons) - real :: tinyreal = tiny(1.0) + real :: tinyreal=tiny(1.0) contains @@ -91,264 +91,264 @@ module budget_interp_mod !> !> @author Marke Iredell, George Gayno, Kyle Gerheiser, Eric Engle !> @date July 2021 - subroutine interpolate_budget_scalar(ipopt, grid_in, grid_out, & - mi, mo, km, ibi, li, gi, & - no, rlat, rlon, ibo, lo, go, iret) - class(ip_grid), intent(in) :: grid_in, grid_out - integer, intent(in) :: ibi(km), ipopt(20) - integer, intent(in) :: km, mi, mo - integer, intent(out) :: ibo(km), iret, no + subroutine interpolate_budget_scalar(ipopt,grid_in,grid_out, & + mi,mo,km,ibi,li,gi, & + no,rlat,rlon,ibo,lo,go,iret) + class(ip_grid),intent(in) :: grid_in,grid_out + integer,intent(in) :: ibi(km),ipopt(20) + integer,intent(in) :: km,mi,mo + integer,intent(out) :: ibo(km),iret,no ! - logical*1, intent(in) :: li(mi, km) - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(in) :: li(mi,km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: gi(mi, km) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: go(mo, km) + real,intent(in) :: gi(mi,km) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: go(mo,km) ! - real, parameter :: fill = -9999. + real,parameter :: fill=-9999. ! - integer :: i1, j1, i2, j2, ib, jb - integer :: ix, jx, ixs, jxs - integer :: k, kxs, kxt - integer :: lb, lsw, mp, mspiral, mx - integer :: n, nb, nb1, nb2, nb3, nb4, nv, nx - integer :: n11(mo), n21(mo), n12(mo), n22(mo) + integer :: i1,j1,i2,j2,ib,jb + integer :: ix,jx,ixs,jxs + integer :: k,kxs,kxt + integer :: lb,lsw,mp,mspiral,mx + integer :: n,nb,nb1,nb2,nb3,nb4,nv,nx + integer :: n11(mo),n21(mo),n12(mo),n22(mo) ! - real :: gb, lat(1), lon(1) - real :: pmp, rb2, rlob(mo), rlab(mo), wb - real :: w11(mo), w21(mo), w12(mo), w22(mo) - real :: wo(mo, km), xf, yf, xi, yi, xx, yy - real :: xpts(mo), ypts(mo), xptb(mo), yptb(mo) - real :: xxx(1), yyy(1) + real :: gb,lat(1),lon(1) + real :: pmp,rb2,rlob(mo),rlab(mo),wb + real :: w11(mo),w21(mo),w12(mo),w22(mo) + real :: wo(mo,km),xf,yf,xi,yi,xx,yy + real :: xpts(mo),ypts(mo),xptb(mo),yptb(mo) + real :: xxx(1),yyy(1) logical :: to_station_points - class(ip_grid), allocatable :: grid_out2 + class(ip_grid),allocatable :: grid_out2 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES. ! DO SUBSECTION OF GRID IF KGDSO(1) IS SUBTRACTED FROM 255. - iret = 0 + iret=0 - select type (grid_out) - type is (ip_station_points_grid) - to_station_points = .true. - allocate (grid_out2, source=grid_out) - call gdswzd(grid_out2, 0, mo, fill, xpts, ypts, rlon, rlat, no) - if (no .eq. 0) iret = 3 - call gdswzd(grid_in, -1, no, fill, xpts, ypts, rlon, rlat, nv) - if (nv .eq. 0) iret = 2 + select type(grid_out) + type is(ip_station_points_grid) + to_station_points=.true. + allocate(grid_out2,source=grid_out) + call gdswzd(grid_out2,0,mo,fill,xpts,ypts,rlon,rlat,no) + if(no.eq.0) iret=3 + call gdswzd(grid_in,-1,no,fill,xpts,ypts,rlon,rlat,nv) + if(nv.eq.0) iret=2 class default - to_station_points = .false. - allocate (grid_out2, source=grid_out) - call gdswzd(grid_out2, 0, mo, fill, xpts, ypts, rlon, rlat, no) - if (no .eq. 0) iret = 3 - end select + to_station_points=.false. + allocate(grid_out2,source=grid_out) + call gdswzd(grid_out2,0,mo,fill,xpts,ypts,rlon,rlat,no) + if(no.eq.0) iret=3 + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SET PARAMETERS - if (ipopt(1) .gt. 16) iret = 32 - mspiral = max(ipopt(20), 1) - nb1 = ipopt(1) - if (nb1 .eq. -1) nb1 = 2 - if (iret .eq. 0 .and. nb1 .lt. 0) iret = 32 - lsw = 1 - if (ipopt(2) .eq. -2) lsw = 2 - if (ipopt(1) .eq. -1 .or. ipopt(2) .eq. -1) lsw = 0 - if (iret .eq. 0 .and. lsw .eq. 1 .and. nb1 .gt. 15) iret = 32 - mp = ipopt(3+ipopt(1)) - if (mp .eq. -1 .or. mp .eq. 0) mp = 50 - if (mp .lt. 0 .or. mp .gt. 100) iret = 32 - pmp = mp*0.01 - if (iret .eq. 0) then - nb2 = 2*nb1+1 - rb2 = 1./nb2 - nb3 = nb2*nb2 - nb4 = nb3 - if (lsw .eq. 2) then - rb2 = 1./(nb1+1) - nb4 = (nb1+1)**4 - elseif (lsw .eq. 1) then - nb4 = ipopt(2) - do ib = 1, nb1 - nb4 = nb4+8*ib*ipopt(2+ib) - end do - end if + if(ipopt(1).gt.16) iret=32 + mspiral=max(ipopt(20),1) + nb1=ipopt(1) + if(nb1.eq.-1) nb1=2 + if(iret.eq.0.and.nb1.lt.0) iret=32 + lsw=1 + if(ipopt(2).eq.-2) lsw=2 + if(ipopt(1).eq.-1.or.ipopt(2).eq.-1) lsw=0 + if(iret.eq.0.and.lsw.eq.1.and.nb1.gt.15) iret=32 + mp=ipopt(3+ipopt(1)) + if(mp.eq.-1.or.mp.eq.0) mp=50 + if(mp.lt.0.or.mp.gt.100) iret=32 + pmp=mp*0.01 + if(iret.eq.0) then + nb2=2*nb1+1 + rb2=1./nb2 + nb3=nb2*nb2 + nb4=nb3 + if(lsw.eq.2) then + rb2=1./(nb1+1) + nb4=(nb1+1)**4 + elseif(lsw.eq.1) then + nb4=ipopt(2) + do ib=1,nb1 + nb4=nb4+8*ib*ipopt(2+ib) + enddo + endif else - nb3 = 0 - nb4 = 1 - end if - do k = 1, km - do n = 1, no - go(n, k) = 0. - wo(n, k) = 0. - end do - end do + nb3=0 + nb4=1 + endif + do k=1,km + do n=1,no + go(n,k)=0. + wo(n,k)=0. + enddo + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! LOOP OVER SAMPLE POINTS IN OUTPUT GRID BOX - do nb = 1, nb3 + do nb=1,nb3 ! LOCATE INPUT POINTS AND COMPUTE THEIR WEIGHTS - jb = (nb-1)/nb2-nb1 - ib = nb-(jb+nb1)*nb2-nb1-1 - lb = max(abs(ib), abs(jb)) - wb = 1 - if (lsw .eq. 2) then - wb = (nb1+1-abs(ib))*(nb1+1-abs(jb)) - elseif (lsw .eq. 1) then - wb = ipopt(2+lb) - end if - if (abs(wb) .gt. tinyreal) then + jb=(nb-1)/nb2-nb1 + ib=nb-(jb+nb1)*nb2-nb1-1 + lb=max(abs(ib),abs(jb)) + wb=1 + if(lsw.eq.2) then + wb=(nb1+1-abs(ib))*(nb1+1-abs(jb)) + elseif(lsw.eq.1) then + wb=ipopt(2+lb) + endif + if(abs(wb).gt.tinyreal) then !$omp parallel do private(n) schedule(static) - do n = 1, no - xptb(n) = xpts(n)+ib*rb2 - yptb(n) = ypts(n)+jb*rb2 - end do + do n=1,no + xptb(n)=xpts(n)+ib*rb2 + yptb(n)=ypts(n)+jb*rb2 + enddo !$omp end parallel do - if (to_station_points) then - call gdswzd(grid_in, 1, no, fill, xptb, yptb, rlob, rlab, nv) - call gdswzd(grid_in, -1, no, fill, xptb, yptb, rlob, rlab, nv) + if(to_station_points) then + call gdswzd(grid_in,1,no,fill,xptb,yptb,rlob,rlab,nv) + call gdswzd(grid_in,-1,no,fill,xptb,yptb,rlob,rlab,nv) else - call gdswzd(grid_out2, 1, no, fill, xptb, yptb, rlob, rlab, nv) - call gdswzd(grid_in, -1, no, fill, xptb, yptb, rlob, rlab, nv) - end if - if (iret .eq. 0 .and. nv .eq. 0 .and. lb .eq. 0) iret = 2 - !$omp parallel do private(n, xi, yi, i1, i2, j1, j2, xf, yf) schedule(static) - do n = 1, no - xi = xptb(n) - yi = yptb(n) - if (abs(xi-fill) .gt. tinyreal .and. abs(yi-fill) .gt. tinyreal) then - i1 = int(xi) - i2 = i1+1 - j1 = int(yi) - j2 = j1+1 - xf = xi-i1 - yf = yi-j1 - n11(n) = grid_in%field_pos(i1, j1) - n21(n) = grid_in%field_pos(i2, j1) - n12(n) = grid_in%field_pos(i1, j2) - n22(n) = grid_in%field_pos(i2, j2) - if (min(n11(n), n21(n), n12(n), n22(n)) .gt. 0) then - w11(n) = (1-xf)*(1-yf) - w21(n) = xf*(1-yf) - w12(n) = (1-xf)*yf - w22(n) = xf*yf + call gdswzd(grid_out2,1,no,fill,xptb,yptb,rlob,rlab,nv) + call gdswzd(grid_in,-1,no,fill,xptb,yptb,rlob,rlab,nv) + endif + if(iret.eq.0.and.nv.eq.0.and.lb.eq.0) iret=2 + !$omp parallel do private(n,xi,yi,i1,i2,j1,j2,xf,yf) schedule(static) + do n=1,no + xi=xptb(n) + yi=yptb(n) + if(abs(xi-fill).gt.tinyreal.and.abs(yi-fill).gt.tinyreal) then + i1=int(xi) + i2=i1+1 + j1=int(yi) + j2=j1+1 + xf=xi-i1 + yf=yi-j1 + n11(n)=grid_in%field_pos(i1,j1) + n21(n)=grid_in%field_pos(i2,j1) + n12(n)=grid_in%field_pos(i1,j2) + n22(n)=grid_in%field_pos(i2,j2) + if(min(n11(n),n21(n),n12(n),n22(n)).gt.0) then + w11(n)=(1-xf)*(1-yf) + w21(n)=xf*(1-yf) + w12(n)=(1-xf)*yf + w22(n)=xf*yf else - n11(n) = 0 - n21(n) = 0 - n12(n) = 0 - n22(n) = 0 - end if + n11(n)=0 + n21(n)=0 + n12(n)=0 + n22(n)=0 + endif else - n11(n) = 0 - n21(n) = 0 - n12(n) = 0 - n22(n) = 0 - end if - end do + n11(n)=0 + n21(n)=0 + n12(n)=0 + n22(n)=0 + endif + enddo !$omp end parallel do ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE WITH OR WITHOUT BITMAPS - !$omp parallel do private(k, n, gb) schedule(static) - do k = 1, km - do n = 1, no - if (n11(n) .gt. 0) then - if (ibi(k) .eq. 0) then - gb = w11(n)*gi(n11(n), k)+w21(n)*gi(n21(n), k) & - +w12(n)*gi(n12(n), k)+w22(n)*gi(n22(n), k) - go(n, k) = go(n, k)+wb*gb - wo(n, k) = wo(n, k)+wb + !$omp parallel do private(k,n,gb) schedule(static) + do k=1,km + do n=1,no + if(n11(n).gt.0) then + if(ibi(k).eq.0) then + gb=w11(n)*gi(n11(n),k)+w21(n)*gi(n21(n),k) & + +w12(n)*gi(n12(n),k)+w22(n)*gi(n22(n),k) + go(n,k)=go(n,k)+wb*gb + wo(n,k)=wo(n,k)+wb else - if (li(n11(n), k)) then - go(n, k) = go(n, k)+wb*w11(n)*gi(n11(n), k) - wo(n, k) = wo(n, k)+wb*w11(n) - end if - if (li(n21(n), k)) then - go(n, k) = go(n, k)+wb*w21(n)*gi(n21(n), k) - wo(n, k) = wo(n, k)+wb*w21(n) - end if - if (li(n12(n), k)) then - go(n, k) = go(n, k)+wb*w12(n)*gi(n12(n), k) - wo(n, k) = wo(n, k)+wb*w12(n) - end if - if (li(n22(n), k)) then - go(n, k) = go(n, k)+wb*w22(n)*gi(n22(n), k) - wo(n, k) = wo(n, k)+wb*w22(n) - end if - end if - end if - end do - end do + if(li(n11(n),k)) then + go(n,k)=go(n,k)+wb*w11(n)*gi(n11(n),k) + wo(n,k)=wo(n,k)+wb*w11(n) + endif + if(li(n21(n),k)) then + go(n,k)=go(n,k)+wb*w21(n)*gi(n21(n),k) + wo(n,k)=wo(n,k)+wb*w21(n) + endif + if(li(n12(n),k)) then + go(n,k)=go(n,k)+wb*w12(n)*gi(n12(n),k) + wo(n,k)=wo(n,k)+wb*w12(n) + endif + if(li(n22(n),k)) then + go(n,k)=go(n,k)+wb*w22(n)*gi(n22(n),k) + wo(n,k)=wo(n,k)+wb*w22(n) + endif + endif + endif + enddo + enddo !$omp end parallel do - end if - end do ! sub-grid points + endif + enddo ! sub-grid points ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE OUTPUT BITMAPS AND FIELDS ! KM is often 1 .. do not do OMP PARALLEL DO here - km_loop: do k = 1, km - ibo(k) = ibi(k) - !$omp parallel do private(n, lat, lon, xxx, yyy, nv, xx, yy, ixs, jxs, mx, kxs, kxt, ix, jx, nx) schedule(static) - n_loop: do n = 1, no - lo(n, k) = wo(n, k) .ge. pmp*nb4 - if (lo(n, k)) then - go(n, k) = go(n, k)/wo(n, k) - elseif (mspiral .gt. 1) then - lat(1) = rlat(n) - lon(1) = rlon(n) - call gdswzd(grid_in, -1, 1, fill, xxx, yyy, lon, lat, nv) - xx = xxx(1) - yy = yyy(1) - if (nv .eq. 1) then - i1 = nint(xx) - j1 = nint(yy) - ixs = int(sign(1., xx-i1)) - jxs = int(sign(1., yy-j1)) - spiral_loop: do mx = 2, mspiral**2 - kxs = int(sqrt(4*mx-2.5)) - kxt = mx-(kxs**2/4+1) - select case (mod(kxs, 4)) - case (1) - ix = i1-ixs*(kxs/4-kxt) - jx = j1-jxs*kxs/4 - case (2) - ix = i1+ixs*(1+kxs/4) - jx = j1-jxs*(kxs/4-kxt) - case (3) - ix = i1+ixs*(1+kxs/4-kxt) - jx = j1+jxs*(1+kxs/4) + km_loop: do k=1,km + ibo(k)=ibi(k) + !$omp parallel do private(n,lat,lon,xxx,yyy,nv,xx,yy,ixs,jxs,mx,kxs,kxt,ix,jx,nx) schedule(static) + n_loop: do n=1,no + lo(n,k)=wo(n,k).ge.pmp*nb4 + if(lo(n,k)) then + go(n,k)=go(n,k)/wo(n,k) + elseif(mspiral.gt.1) then + lat(1)=rlat(n) + lon(1)=rlon(n) + call gdswzd(grid_in,-1,1,fill,xxx,yyy,lon,lat,nv) + xx=xxx(1) + yy=yyy(1) + if(nv.eq.1) then + i1=nint(xx) + j1=nint(yy) + ixs=int(sign(1.,xx-i1)) + jxs=int(sign(1.,yy-j1)) + spiral_loop: do mx=2,mspiral**2 + kxs=int(sqrt(4*mx-2.5)) + kxt=mx-(kxs**2/4+1) + select case(mod(kxs,4)) + case(1) + ix=i1-ixs*(kxs/4-kxt) + jx=j1-jxs*kxs/4 + case(2) + ix=i1+ixs*(1+kxs/4) + jx=j1-jxs*(kxs/4-kxt) + case(3) + ix=i1+ixs*(1+kxs/4-kxt) + jx=j1+jxs*(1+kxs/4) case default - ix = i1-ixs*kxs/4 - jx = j1+jxs*(kxs/4-kxt) - end select - nx = grid_in%field_pos(ix, jx) - if (nx .gt. 0.) then - if (li(nx, k) .or. ibi(k) .eq. 0) then - go(n, k) = gi(nx, k) - lo(n, k) = .true. + ix=i1-ixs*kxs/4 + jx=j1+jxs*(kxs/4-kxt) + endselect + nx=grid_in%field_pos(ix,jx) + if(nx.gt.0.) then + if(li(nx,k).or.ibi(k).eq.0) then + go(n,k)=gi(nx,k) + lo(n,k)=.true. cycle n_loop - end if - end if - end do spiral_loop - ibo(k) = 1 - go(n, k) = 0. + endif + endif + enddo spiral_loop + ibo(k)=1 + go(n,k)=0. else - ibo(k) = 1 - go(n, k) = 0. - end if + ibo(k)=1 + go(n,k)=0. + endif else ! no spiral search option - ibo(k) = 1 - go(n, k) = 0. - end if - end do n_loop + ibo(k)=1 + go(n,k)=0. + endif + enddo n_loop !$omp end parallel do - end do km_loop + enddo km_loop - select type (grid_out2) - type is (ip_equid_cylind_grid) - call polfixs(no, mo, km, rlat, ibo, lo, go) - end select + select type(grid_out2) + type is(ip_equid_cylind_grid) + call polfixs(no,mo,km,rlat,ibo,lo,go) + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine interpolate_budget_scalar + endsubroutine interpolate_budget_scalar !> This subprogram performs budget interpolation from any grid to !> any grid (or to random station points) for vector fields. @@ -420,295 +420,295 @@ end subroutine interpolate_budget_scalar !> !> @author Marke Iredell, George Gayno, Kyle Gerheiser, Eric Engle !> @date July 2021 - subroutine interpolate_budget_vector(ipopt, grid_in, grid_out, & - mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - class(ip_grid), intent(in) :: grid_in, grid_out - integer, intent(in) :: ipopt(20), ibi(km) - integer, intent(in) :: km, mi, mo - integer, intent(out) :: iret, no, ibo(km) + subroutine interpolate_budget_vector(ipopt,grid_in,grid_out, & + mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + class(ip_grid),intent(in) :: grid_in,grid_out + integer,intent(in) :: ipopt(20),ibi(km) + integer,intent(in) :: km,mi,mo + integer,intent(out) :: iret,no,ibo(km) ! - logical*1, intent(in) :: li(mi, km) - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(in) :: li(mi,km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: ui(mi, km), vi(mi, km) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: uo(mo, km), vo(mo, km) - real, intent(out) :: crot(mo), srot(mo) + real,intent(in) :: ui(mi,km),vi(mi,km) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: uo(mo,km),vo(mo,km) + real,intent(out) :: crot(mo),srot(mo) ! - real, parameter :: fill = -9999. + real,parameter :: fill=-9999. ! - integer :: i1, i2, j1, j2, ib, jb, lsw, mp - integer :: k, lb, n, nb, nb1, nb2, nb3, nb4, nv - integer :: n11(mo), n21(mo), n12(mo), n22(mo) + integer :: i1,i2,j1,j2,ib,jb,lsw,mp + integer :: k,lb,n,nb,nb1,nb2,nb3,nb4,nv + integer :: n11(mo),n21(mo),n12(mo),n22(mo) ! logical :: same_grid ! - real :: cm11, sm11, cm12, sm12 - real :: cm21, sm21, cm22, sm22 - real :: pmp, rb2 - real :: c11(mo), c21(mo), c12(mo), c22(mo) - real :: s11(mo), s21(mo), s12(mo), s22(mo) - real :: w11(mo), w21(mo), w12(mo), w22(mo) - real :: ub, vb, wb, urot, vrot - real :: u11, v11, u21, v21, u12, v12, u22, v22 - real :: wi1, wj1, wi2, wj2 - real :: wo(mo, km), xi, yi - real :: xpts(mo), ypts(mo) - real :: xptb(mo), yptb(mo), rlob(mo), rlab(mo) + real :: cm11,sm11,cm12,sm12 + real :: cm21,sm21,cm22,sm22 + real :: pmp,rb2 + real :: c11(mo),c21(mo),c12(mo),c22(mo) + real :: s11(mo),s21(mo),s12(mo),s22(mo) + real :: w11(mo),w21(mo),w12(mo),w22(mo) + real :: ub,vb,wb,urot,vrot + real :: u11,v11,u21,v21,u12,v12,u22,v22 + real :: wi1,wj1,wi2,wj2 + real :: wo(mo,km),xi,yi + real :: xpts(mo),ypts(mo) + real :: xptb(mo),yptb(mo),rlob(mo),rlab(mo) logical :: to_station_points - class(ip_grid), allocatable :: grid_out2 + class(ip_grid),allocatable :: grid_out2 ! Save coeffecients between calls and only compute if grids have changed - integer, save :: mix = -1 - real, allocatable, save :: croi(:), sroi(:) - real, allocatable, save :: xpti(:), ypti(:), rloi(:), rlai(:) + integer,save :: mix=-1 + real,allocatable,save :: croi(:),sroi(:) + real,allocatable,save :: xpti(:),ypti(:),rloi(:),rlai(:) - class(ip_grid), allocatable, save :: prev_grid_in + class(ip_grid),allocatable,save :: prev_grid_in - iret = 0 + iret=0 ! Negative grid number means interpolate to subgrid ! The type of the subgrid is calculated by 255 + - select type (grid_out) - type is (ip_station_points_grid) - to_station_points = .true. - allocate (grid_out2, source=grid_out) - call gdswzd(grid_out2, 0, mo, fill, xpts, ypts, rlon, rlat, no, crot, srot) - if (no .eq. 0) iret = 3 - call gdswzd(grid_in, -1, no, fill, xpts, ypts, rlon, rlat, nv, crot, srot) - if (nv .eq. 0) iret = 2 + select type(grid_out) + type is(ip_station_points_grid) + to_station_points=.true. + allocate(grid_out2,source=grid_out) + call gdswzd(grid_out2,0,mo,fill,xpts,ypts,rlon,rlat,no,crot,srot) + if(no.eq.0) iret=3 + call gdswzd(grid_in,-1,no,fill,xpts,ypts,rlon,rlat,nv,crot,srot) + if(nv.eq.0) iret=2 class default - to_station_points = .false. - allocate (grid_out2, source=grid_out) - call gdswzd(grid_out2, 0, mo, fill, xpts, ypts, rlon, rlat, no, crot, srot) - end select + to_station_points=.false. + allocate(grid_out2,source=grid_out) + call gdswzd(grid_out2,0,mo,fill,xpts,ypts,rlon,rlat,no,crot,srot) + endselect - if (.not. allocated(prev_grid_in)) then - allocate (prev_grid_in, source=grid_in) + if(.not.allocated(prev_grid_in)) then + allocate(prev_grid_in,source=grid_in) - same_grid = .false. + same_grid=.false. else - same_grid = grid_in .eq. prev_grid_in + same_grid=grid_in.eq.prev_grid_in - if (.not. same_grid) then - deallocate (prev_grid_in) - allocate (prev_grid_in, source=grid_in) - end if - end if + if(.not.same_grid) then + deallocate(prev_grid_in) + allocate(prev_grid_in,source=grid_in) + endif + endif - if (.not. same_grid) then - if (mix .ne. mi) then - if (mix .ge. 0) deallocate (xpti, ypti, rloi, rlai, croi, sroi) - allocate (xpti(mi), ypti(mi), rloi(mi), rlai(mi), croi(mi), sroi(mi)) - mix = mi - end if - call gdswzd(grid_in, 0, mi, fill, xpti, ypti, rloi, rlai, nv, croi, sroi) - end if + if(.not.same_grid) then + if(mix.ne.mi) then + if(mix.ge.0) deallocate(xpti,ypti,rloi,rlai,croi,sroi) + allocate(xpti(mi),ypti(mi),rloi(mi),rlai(mi),croi(mi),sroi(mi)) + mix=mi + endif + call gdswzd(grid_in,0,mi,fill,xpti,ypti,rloi,rlai,nv,croi,sroi) + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SET PARAMETERS - nb1 = ipopt(1) - if (nb1 .eq. -1) nb1 = 2 - if (iret .eq. 0 .and. nb1 .lt. 0) iret = 32 - lsw = 1 - if (ipopt(2) .eq. -2) lsw = 2 - if (ipopt(1) .eq. -1 .or. ipopt(2) .eq. -1) lsw = 0 - if (iret .eq. 0 .and. lsw .eq. 1 .and. nb1 .gt. 15) iret = 32 - mp = ipopt(3+ipopt(1)) - if (mp .eq. -1 .or. mp .eq. 0) mp = 50 - if (mp .lt. 0 .or. mp .gt. 100) iret = 32 - pmp = mp*0.01 - if (iret .eq. 0) then - nb2 = 2*nb1+1 - rb2 = 1./nb2 - nb3 = nb2*nb2 - nb4 = nb3 - if (lsw .eq. 2) then - rb2 = 1./(nb1+1) - nb4 = (nb1+1)**4 - elseif (lsw .eq. 1) then - nb4 = ipopt(2) - do ib = 1, nb1 - nb4 = nb4+8*ib*ipopt(2+ib) - end do - end if + nb1=ipopt(1) + if(nb1.eq.-1) nb1=2 + if(iret.eq.0.and.nb1.lt.0) iret=32 + lsw=1 + if(ipopt(2).eq.-2) lsw=2 + if(ipopt(1).eq.-1.or.ipopt(2).eq.-1) lsw=0 + if(iret.eq.0.and.lsw.eq.1.and.nb1.gt.15) iret=32 + mp=ipopt(3+ipopt(1)) + if(mp.eq.-1.or.mp.eq.0) mp=50 + if(mp.lt.0.or.mp.gt.100) iret=32 + pmp=mp*0.01 + if(iret.eq.0) then + nb2=2*nb1+1 + rb2=1./nb2 + nb3=nb2*nb2 + nb4=nb3 + if(lsw.eq.2) then + rb2=1./(nb1+1) + nb4=(nb1+1)**4 + elseif(lsw.eq.1) then + nb4=ipopt(2) + do ib=1,nb1 + nb4=nb4+8*ib*ipopt(2+ib) + enddo + endif else - nb3 = 0 - nb4 = 1 - end if - do k = 1, km - do n = 1, no - uo(n, k) = 0 - vo(n, k) = 0 - wo(n, k) = 0. - end do - end do + nb3=0 + nb4=1 + endif + do k=1,km + do n=1,no + uo(n,k)=0 + vo(n,k)=0 + wo(n,k)=0. + enddo + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! LOOP OVER SAMPLE POINTS IN OUTPUT GRID BOX - do nb = 1, nb3 + do nb=1,nb3 ! LOCATE INPUT POINTS AND COMPUTE THEIR WEIGHTS AND ROTATIONS - jb = (nb-1)/nb2-nb1 - ib = nb-(jb+nb1)*nb2-nb1-1 - lb = max(abs(ib), abs(jb)) - wb = 1 - if (ipopt(2) .eq. -2) then - wb = (nb1+1-abs(ib))*(nb1+1-abs(jb)) - elseif (ipopt(2) .ne. -1) then - wb = ipopt(2+lb) - end if - if (abs(wb) .gt. tinyreal) then + jb=(nb-1)/nb2-nb1 + ib=nb-(jb+nb1)*nb2-nb1-1 + lb=max(abs(ib),abs(jb)) + wb=1 + if(ipopt(2).eq.-2) then + wb=(nb1+1-abs(ib))*(nb1+1-abs(jb)) + elseif(ipopt(2).ne.-1) then + wb=ipopt(2+lb) + endif + if(abs(wb).gt.tinyreal) then !$omp parallel do private(n) schedule(static) - do n = 1, no - xptb(n) = xpts(n)+ib*rb2 - yptb(n) = ypts(n)+jb*rb2 - end do + do n=1,no + xptb(n)=xpts(n)+ib*rb2 + yptb(n)=ypts(n)+jb*rb2 + enddo !$omp end parallel do - if (to_station_points) then - call gdswzd(grid_in, 1, no, fill, xptb, yptb, rlob, rlab, nv) - call gdswzd(grid_in, -1, no, fill, xptb, yptb, rlob, rlab, nv) + if(to_station_points) then + call gdswzd(grid_in,1,no,fill,xptb,yptb,rlob,rlab,nv) + call gdswzd(grid_in,-1,no,fill,xptb,yptb,rlob,rlab,nv) else - call gdswzd(grid_out2, 1, no, fill, xptb, yptb, rlob, rlab, nv) - call gdswzd(grid_in, -1, no, fill, xptb, yptb, rlob, rlab, nv) - end if - if (iret .eq. 0 .and. nv .eq. 0 .and. lb .eq. 0) iret = 2 - !$omp parallel do private(n, xi, yi, i1, i2, wi1, wi2, j1, j2, wj1, wj2, cm11, cm21, cm12, cm22, sm11, sm21, sm12, sm22) & + call gdswzd(grid_out2,1,no,fill,xptb,yptb,rlob,rlab,nv) + call gdswzd(grid_in,-1,no,fill,xptb,yptb,rlob,rlab,nv) + endif + if(iret.eq.0.and.nv.eq.0.and.lb.eq.0) iret=2 + !$omp parallel do private(n,xi,yi,i1,i2,wi1,wi2,j1,j2,wj1,wj2,cm11,cm21,cm12,cm22,sm11,sm21,sm12,sm22) & !$omp schedule(static) - do n = 1, no - xi = xptb(n) - yi = yptb(n) - if (abs(xi-fill) .gt. tinyreal .and. abs(yi-fill) .gt. tinyreal) then - i1 = int(xi) - i2 = i1+1 - wi2 = xi-i1 - wi1 = 1-wi2 - j1 = int(yi) - j2 = j1+1 - wj2 = yi-j1 - wj1 = 1-wj2 - n11(n) = grid_in%field_pos(i1, j1) - n21(n) = grid_in%field_pos(i2, j1) - n12(n) = grid_in%field_pos(i1, j2) - n22(n) = grid_in%field_pos(i2, j2) - if (min(n11(n), n21(n), n12(n), n22(n)) .gt. 0) then - w11(n) = wi1*wj1 - w21(n) = wi2*wj1 - w12(n) = wi1*wj2 - w22(n) = wi2*wj2 - call movect(rlai(n11(n)), rloi(n11(n)), rlat(n), rlon(n), cm11, sm11) - call movect(rlai(n21(n)), rloi(n21(n)), rlat(n), rlon(n), cm21, sm21) - call movect(rlai(n12(n)), rloi(n12(n)), rlat(n), rlon(n), cm12, sm12) - call movect(rlai(n22(n)), rloi(n22(n)), rlat(n), rlon(n), cm22, sm22) - c11(n) = cm11*croi(n11(n))+sm11*sroi(n11(n)) - s11(n) = sm11*croi(n11(n))-cm11*sroi(n11(n)) - c21(n) = cm21*croi(n21(n))+sm21*sroi(n21(n)) - s21(n) = sm21*croi(n21(n))-cm21*sroi(n21(n)) - c12(n) = cm12*croi(n12(n))+sm12*sroi(n12(n)) - s12(n) = sm12*croi(n12(n))-cm12*sroi(n12(n)) - c22(n) = cm22*croi(n22(n))+sm22*sroi(n22(n)) - s22(n) = sm22*croi(n22(n))-cm22*sroi(n22(n)) + do n=1,no + xi=xptb(n) + yi=yptb(n) + if(abs(xi-fill).gt.tinyreal.and.abs(yi-fill).gt.tinyreal) then + i1=int(xi) + i2=i1+1 + wi2=xi-i1 + wi1=1-wi2 + j1=int(yi) + j2=j1+1 + wj2=yi-j1 + wj1=1-wj2 + n11(n)=grid_in%field_pos(i1,j1) + n21(n)=grid_in%field_pos(i2,j1) + n12(n)=grid_in%field_pos(i1,j2) + n22(n)=grid_in%field_pos(i2,j2) + if(min(n11(n),n21(n),n12(n),n22(n)).gt.0) then + w11(n)=wi1*wj1 + w21(n)=wi2*wj1 + w12(n)=wi1*wj2 + w22(n)=wi2*wj2 + call movect(rlai(n11(n)),rloi(n11(n)),rlat(n),rlon(n),cm11,sm11) + call movect(rlai(n21(n)),rloi(n21(n)),rlat(n),rlon(n),cm21,sm21) + call movect(rlai(n12(n)),rloi(n12(n)),rlat(n),rlon(n),cm12,sm12) + call movect(rlai(n22(n)),rloi(n22(n)),rlat(n),rlon(n),cm22,sm22) + c11(n)=cm11*croi(n11(n))+sm11*sroi(n11(n)) + s11(n)=sm11*croi(n11(n))-cm11*sroi(n11(n)) + c21(n)=cm21*croi(n21(n))+sm21*sroi(n21(n)) + s21(n)=sm21*croi(n21(n))-cm21*sroi(n21(n)) + c12(n)=cm12*croi(n12(n))+sm12*sroi(n12(n)) + s12(n)=sm12*croi(n12(n))-cm12*sroi(n12(n)) + c22(n)=cm22*croi(n22(n))+sm22*sroi(n22(n)) + s22(n)=sm22*croi(n22(n))-cm22*sroi(n22(n)) else - n11(n) = 0 - n21(n) = 0 - n12(n) = 0 - n22(n) = 0 - end if + n11(n)=0 + n21(n)=0 + n12(n)=0 + n22(n)=0 + endif else - n11(n) = 0 - n21(n) = 0 - n12(n) = 0 - n22(n) = 0 - end if - end do + n11(n)=0 + n21(n)=0 + n12(n)=0 + n22(n)=0 + endif + enddo !$omp end parallel do ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE WITH OR WITHOUT BITMAPS ! KM IS OFTEN 1 .. DO NO PUT OMP PARALLEL DO HERE - do k = 1, km - !$omp parallel do private(n, u11, u12, u21, u22, ub, v11, v12, v21, v22, vb) schedule(static) - do n = 1, no - if (n11(n) .gt. 0) then - if (ibi(k) .eq. 0) then - u11 = c11(n)*ui(n11(n), k)-s11(n)*vi(n11(n), k) - v11 = s11(n)*ui(n11(n), k)+c11(n)*vi(n11(n), k) - u21 = c21(n)*ui(n21(n), k)-s21(n)*vi(n21(n), k) - v21 = s21(n)*ui(n21(n), k)+c21(n)*vi(n21(n), k) - u12 = c12(n)*ui(n12(n), k)-s12(n)*vi(n12(n), k) - v12 = s12(n)*ui(n12(n), k)+c12(n)*vi(n12(n), k) - u22 = c22(n)*ui(n22(n), k)-s22(n)*vi(n22(n), k) - v22 = s22(n)*ui(n22(n), k)+c22(n)*vi(n22(n), k) - ub = w11(n)*u11+w21(n)*u21+w12(n)*u12+w22(n)*u22 - vb = w11(n)*v11+w21(n)*v21+w12(n)*v12+w22(n)*v22 - uo(n, k) = uo(n, k)+wb*ub - vo(n, k) = vo(n, k)+wb*vb - wo(n, k) = wo(n, k)+wb + do k=1,km + !$omp parallel do private(n,u11,u12,u21,u22,ub,v11,v12,v21,v22,vb) schedule(static) + do n=1,no + if(n11(n).gt.0) then + if(ibi(k).eq.0) then + u11=c11(n)*ui(n11(n),k)-s11(n)*vi(n11(n),k) + v11=s11(n)*ui(n11(n),k)+c11(n)*vi(n11(n),k) + u21=c21(n)*ui(n21(n),k)-s21(n)*vi(n21(n),k) + v21=s21(n)*ui(n21(n),k)+c21(n)*vi(n21(n),k) + u12=c12(n)*ui(n12(n),k)-s12(n)*vi(n12(n),k) + v12=s12(n)*ui(n12(n),k)+c12(n)*vi(n12(n),k) + u22=c22(n)*ui(n22(n),k)-s22(n)*vi(n22(n),k) + v22=s22(n)*ui(n22(n),k)+c22(n)*vi(n22(n),k) + ub=w11(n)*u11+w21(n)*u21+w12(n)*u12+w22(n)*u22 + vb=w11(n)*v11+w21(n)*v21+w12(n)*v12+w22(n)*v22 + uo(n,k)=uo(n,k)+wb*ub + vo(n,k)=vo(n,k)+wb*vb + wo(n,k)=wo(n,k)+wb else - if (li(n11(n), k)) then - u11 = c11(n)*ui(n11(n), k)-s11(n)*vi(n11(n), k) - v11 = s11(n)*ui(n11(n), k)+c11(n)*vi(n11(n), k) - uo(n, k) = uo(n, k)+wb*w11(n)*u11 - vo(n, k) = vo(n, k)+wb*w11(n)*v11 - wo(n, k) = wo(n, k)+wb*w11(n) - end if - if (li(n21(n), k)) then - u21 = c21(n)*ui(n21(n), k)-s21(n)*vi(n21(n), k) - v21 = s21(n)*ui(n21(n), k)+c21(n)*vi(n21(n), k) - uo(n, k) = uo(n, k)+wb*w21(n)*u21 - vo(n, k) = vo(n, k)+wb*w21(n)*v21 - wo(n, k) = wo(n, k)+wb*w21(n) - end if - if (li(n12(n), k)) then - u12 = c12(n)*ui(n12(n), k)-s12(n)*vi(n12(n), k) - v12 = s12(n)*ui(n12(n), k)+c12(n)*vi(n12(n), k) - uo(n, k) = uo(n, k)+wb*w12(n)*u12 - vo(n, k) = vo(n, k)+wb*w12(n)*v12 - wo(n, k) = wo(n, k)+wb*w12(n) - end if - if (li(n22(n), k)) then - u22 = c22(n)*ui(n22(n), k)-s22(n)*vi(n22(n), k) - v22 = s22(n)*ui(n22(n), k)+c22(n)*vi(n22(n), k) - uo(n, k) = uo(n, k)+wb*w22(n)*u22 - vo(n, k) = vo(n, k)+wb*w22(n)*v22 - wo(n, k) = wo(n, k)+wb*w22(n) - end if - end if - end if - end do + if(li(n11(n),k)) then + u11=c11(n)*ui(n11(n),k)-s11(n)*vi(n11(n),k) + v11=s11(n)*ui(n11(n),k)+c11(n)*vi(n11(n),k) + uo(n,k)=uo(n,k)+wb*w11(n)*u11 + vo(n,k)=vo(n,k)+wb*w11(n)*v11 + wo(n,k)=wo(n,k)+wb*w11(n) + endif + if(li(n21(n),k)) then + u21=c21(n)*ui(n21(n),k)-s21(n)*vi(n21(n),k) + v21=s21(n)*ui(n21(n),k)+c21(n)*vi(n21(n),k) + uo(n,k)=uo(n,k)+wb*w21(n)*u21 + vo(n,k)=vo(n,k)+wb*w21(n)*v21 + wo(n,k)=wo(n,k)+wb*w21(n) + endif + if(li(n12(n),k)) then + u12=c12(n)*ui(n12(n),k)-s12(n)*vi(n12(n),k) + v12=s12(n)*ui(n12(n),k)+c12(n)*vi(n12(n),k) + uo(n,k)=uo(n,k)+wb*w12(n)*u12 + vo(n,k)=vo(n,k)+wb*w12(n)*v12 + wo(n,k)=wo(n,k)+wb*w12(n) + endif + if(li(n22(n),k)) then + u22=c22(n)*ui(n22(n),k)-s22(n)*vi(n22(n),k) + v22=s22(n)*ui(n22(n),k)+c22(n)*vi(n22(n),k) + uo(n,k)=uo(n,k)+wb*w22(n)*u22 + vo(n,k)=vo(n,k)+wb*w22(n)*v22 + wo(n,k)=wo(n,k)+wb*w22(n) + endif + endif + endif + enddo !$omp end parallel do - end do - end if - end do + enddo + endif + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE OUTPUT BITMAPS AND FIELDS ! KM is often 1, do not put OMP PARALLEL here - do k = 1, km - ibo(k) = ibi(k) - !$omp parallel do private(n, urot, vrot) schedule(static) - do n = 1, no - lo(n, k) = wo(n, k) .ge. pmp*nb4 - if (lo(n, k)) then - uo(n, k) = uo(n, k)/wo(n, k) - vo(n, k) = vo(n, k)/wo(n, k) - urot = crot(n)*uo(n, k)-srot(n)*vo(n, k) - vrot = srot(n)*uo(n, k)+crot(n)*vo(n, k) - uo(n, k) = urot - vo(n, k) = vrot + do k=1,km + ibo(k)=ibi(k) + !$omp parallel do private(n,urot,vrot) schedule(static) + do n=1,no + lo(n,k)=wo(n,k).ge.pmp*nb4 + if(lo(n,k)) then + uo(n,k)=uo(n,k)/wo(n,k) + vo(n,k)=vo(n,k)/wo(n,k) + urot=crot(n)*uo(n,k)-srot(n)*vo(n,k) + vrot=srot(n)*uo(n,k)+crot(n)*vo(n,k) + uo(n,k)=urot + vo(n,k)=vrot else - ibo(k) = 1 - uo(n, k) = 0. - vo(n, k) = 0. - end if - end do + ibo(k)=1 + uo(n,k)=0. + vo(n,k)=0. + endif + enddo !$omp end parallel do - end do + enddo - select type (grid_out2) - type is (ip_equid_cylind_grid) - call polfixv(no, mo, km, rlat, rlon, ibo, lo, uo, vo) - end select + select type(grid_out2) + type is(ip_equid_cylind_grid) + call polfixv(no,mo,km,rlat,rlon,ibo,lo,uo,vo) + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine interpolate_budget_vector + endsubroutine interpolate_budget_vector -end module budget_interp_mod +endmodule budget_interp_mod diff --git a/src/earth_radius_mod.F90 b/src/earth_radius_mod.F90 index 212a2284..bb235f35 100644 --- a/src/earth_radius_mod.F90 +++ b/src/earth_radius_mod.F90 @@ -37,60 +37,60 @@ module earth_radius_mod !> @param[out] eccen_squared real earth eccentricity squared !> !> @author Gayno @date 2015-07-14 - subroutine earth_radius(igdtmpl, igdtlen, radius, eccen_squared) + subroutine earth_radius(igdtmpl,igdtlen,radius,eccen_squared) implicit none - integer, intent(in) :: igdtlen - integer, intent(in) :: igdtmpl(igdtlen) + integer,intent(in) :: igdtlen + integer,intent(in) :: igdtmpl(igdtlen) - real, intent(out) :: eccen_squared - real, intent(out) :: radius + real,intent(out) :: eccen_squared + real,intent(out) :: radius real :: flat - real :: major_axis, minor_axis + real :: major_axis,minor_axis - select case (igdtmpl(1)) - case (0) - radius = 6367470.0 - eccen_squared = 0.0 - case (1) ! USER SPECIFIED SPHERICAL - radius = float(igdtmpl(3))/float(10**igdtmpl(2)) - eccen_squared = 0.0 - case (2) ! IAU 1965 - radius = 6378160.0 ! SEMI MAJOR AXIS - flat = 1.0/297.0 ! FLATTENING - eccen_squared = (2.0*flat)-(flat**2) - case (3) ! USER SPECIFIED ELLIPTICAL (KM) - major_axis = float(igdtmpl(5))/float(10**igdtmpl(4)) - major_axis = major_axis*1000.0 - minor_axis = float(igdtmpl(7))/float(10**igdtmpl(6)) - minor_axis = minor_axis*1000.0 - eccen_squared = 1.0-(minor_axis**2/major_axis**2) - radius = major_axis - case (4) ! IAG-GRS80 MODEL - radius = 6378137.0 ! SEMI MAJOR AXIS - flat = 1.0/298.2572 ! FLATTENING - eccen_squared = (2.0*flat)-(flat**2) - case (5) ! WGS84 DATUM - radius = 6378137.0 ! SEMI MAJOR AXIS - eccen_squared = 0.00669437999013 - case (6) - radius = 6371229.0 - eccen_squared = 0.0 - case (7) ! USER SPECIFIED ELLIPTICAL (M) - major_axis = float(igdtmpl(5))/float(10**igdtmpl(4)) - minor_axis = float(igdtmpl(7))/float(10**igdtmpl(6)) - eccen_squared = 1.0-(minor_axis**2/major_axis**2) - radius = major_axis - case (8) - radius = 6371200.0 - eccen_squared = 0.0 + select case(igdtmpl(1)) + case(0) + radius=6367470.0 + eccen_squared=0.0 + case(1) ! USER SPECIFIED SPHERICAL + radius=float(igdtmpl(3))/float(10**igdtmpl(2)) + eccen_squared=0.0 + case(2) ! IAU 1965 + radius=6378160.0 ! SEMI MAJOR AXIS + flat=1.0/297.0 ! FLATTENING + eccen_squared=(2.0*flat)-(flat**2) + case(3) ! USER SPECIFIED ELLIPTICAL (KM) + major_axis=float(igdtmpl(5))/float(10**igdtmpl(4)) + major_axis=major_axis*1000.0 + minor_axis=float(igdtmpl(7))/float(10**igdtmpl(6)) + minor_axis=minor_axis*1000.0 + eccen_squared=1.0-(minor_axis**2/major_axis**2) + radius=major_axis + case(4) ! IAG-GRS80 MODEL + radius=6378137.0 ! SEMI MAJOR AXIS + flat=1.0/298.2572 ! FLATTENING + eccen_squared=(2.0*flat)-(flat**2) + case(5) ! WGS84 DATUM + radius=6378137.0 ! SEMI MAJOR AXIS + eccen_squared=0.00669437999013 + case(6) + radius=6371229.0 + eccen_squared=0.0 + case(7) ! USER SPECIFIED ELLIPTICAL (M) + major_axis=float(igdtmpl(5))/float(10**igdtmpl(4)) + minor_axis=float(igdtmpl(7))/float(10**igdtmpl(6)) + eccen_squared=1.0-(minor_axis**2/major_axis**2) + radius=major_axis + case(8) + radius=6371200.0 + eccen_squared=0.0 case default - radius = -9999. - eccen_squared = -9999. - end select + radius=-9999. + eccen_squared=-9999. + endselect ! return ! - end subroutine earth_radius -end module earth_radius_mod + endsubroutine earth_radius +endmodule earth_radius_mod diff --git a/src/gdswzd_c.F90 b/src/gdswzd_c.F90 index 47e03681..078b9b33 100644 --- a/src/gdswzd_c.F90 +++ b/src/gdswzd_c.F90 @@ -170,44 +170,44 @@ module gdswzd_c_mod !> square of the map factor in the case of conformal projections.) !> !> @author JOVIC @date 2016-04-10 - subroutine gdswzd_c(igdtnum, igdtmpl, igdtlen, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, crot, srot, & - xlon, xlat, ylon, ylat, area) bind(c, name='gdswzd') - use, intrinsic :: iso_c_binding + subroutine gdswzd_c(igdtnum,igdtmpl,igdtlen,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret,crot,srot, & + xlon,xlat,ylon,ylat,area) bind(c,name='gdswzd') + use,intrinsic :: iso_c_binding use gdswzd_mod implicit none #if (LSIZE==8) - integer(KIND=c_long), intent(in) :: igdtmpl(igdtlen) - integer(KIND=c_long), value, intent(in) :: igdtnum, igdtlen - integer(KIND=c_long), value, intent(in) :: iopt, npts - integer(KIND=c_long), intent(out) :: nret + integer(KIND=c_long),intent(in) :: igdtmpl(igdtlen) + integer(KIND=c_long),value,intent(in) :: igdtnum,igdtlen + integer(KIND=c_long),value,intent(in) :: iopt,npts + integer(KIND=c_long),intent(out) :: nret #else - integer(KIND=c_int), intent(in) :: igdtmpl(igdtlen) - integer(KIND=c_int), value, intent(in) :: igdtnum, igdtlen - integer(KIND=c_int), value, intent(in) :: iopt, npts - integer(KIND=c_int), intent(out) :: nret + integer(KIND=c_int),intent(in) :: igdtmpl(igdtlen) + integer(KIND=c_int),value,intent(in) :: igdtnum,igdtlen + integer(KIND=c_int),value,intent(in) :: iopt,npts + integer(KIND=c_int),intent(out) :: nret #endif #if (LSIZE==4) - real(KIND=c_float), value, intent(in) :: fill - real(KIND=c_float), intent(inout) :: xpts(npts), ypts(npts), rlon(npts), rlat(npts) - real(KIND=c_float), intent(out) :: crot(npts), srot(npts), xlon(npts), xlat(npts) - real(KIND=c_float), intent(out) :: ylon(npts), ylat(npts), area(npts) + real(KIND=c_float),value,intent(in) :: fill + real(KIND=c_float),intent(inout) :: xpts(npts),ypts(npts),rlon(npts),rlat(npts) + real(KIND=c_float),intent(out) :: crot(npts),srot(npts),xlon(npts),xlat(npts) + real(KIND=c_float),intent(out) :: ylon(npts),ylat(npts),area(npts) #else - real(KIND=c_double), value, intent(in) :: fill - real(KIND=c_double), intent(inout) :: xpts(npts), ypts(npts), rlon(npts), rlat(npts) - real(KIND=c_double), intent(out) :: crot(npts), srot(npts), xlon(npts), xlat(npts) - real(KIND=c_double), intent(out) :: ylon(npts), ylat(npts), area(npts) + real(KIND=c_double),value,intent(in) :: fill + real(KIND=c_double),intent(inout) :: xpts(npts),ypts(npts),rlon(npts),rlat(npts) + real(KIND=c_double),intent(out) :: crot(npts),srot(npts),xlon(npts),xlat(npts) + real(KIND=c_double),intent(out) :: ylon(npts),ylat(npts),area(npts) #endif - call gdswzd(igdtnum, igdtmpl, igdtlen, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + call gdswzd(igdtnum,igdtmpl,igdtlen,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) - end subroutine gdswzd_c + endsubroutine gdswzd_c !> C wrapper for routine gdswzd. !> Use this routine to call 'gdswzd' from a C or C++ program. @@ -256,41 +256,41 @@ end subroutine gdswzd_c !> square of the map factor in the case of conformal projections.) !> !> @author JOVIC @date 2016-04-10 - subroutine gdswzd_c_grib1(kgds, iopt, npts, fill, xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) bind(c, name='gdswzd_grib1') - use, intrinsic :: iso_c_binding + subroutine gdswzd_c_grib1(kgds,iopt,npts,fill,xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) bind(c,name='gdswzd_grib1') + use,intrinsic :: iso_c_binding use gdswzd_mod implicit none #if (LSIZE==8) - integer(KIND=c_long), intent(in) :: kgds(200) - integer(KIND=c_long), value, intent(in) :: iopt - integer(KIND=c_long), value, intent(in) :: npts - integer(KIND=c_long), intent(out) :: nret + integer(KIND=c_long),intent(in) :: kgds(200) + integer(KIND=c_long),value,intent(in) :: iopt + integer(KIND=c_long),value,intent(in) :: npts + integer(KIND=c_long),intent(out) :: nret #else - integer(KIND=c_int), intent(in) :: kgds(200) - integer(KIND=c_int), value, intent(in) :: iopt - integer(KIND=c_int), value, intent(in) :: npts - integer(KIND=c_int), intent(out) :: nret + integer(KIND=c_int),intent(in) :: kgds(200) + integer(KIND=c_int),value,intent(in) :: iopt + integer(KIND=c_int),value,intent(in) :: npts + integer(KIND=c_int),intent(out) :: nret #endif #if (LSIZE==4) - real(KIND=c_float), value, intent(in) :: fill - real(KIND=c_float), intent(inout) :: xpts(npts), ypts(npts), rlon(npts), rlat(npts) - real(KIND=c_float), intent(out) :: crot(npts), srot(npts), xlon(npts), xlat(npts) - real(KIND=c_float), intent(out) :: ylon(npts), ylat(npts), area(npts) + real(KIND=c_float),value,intent(in) :: fill + real(KIND=c_float),intent(inout) :: xpts(npts),ypts(npts),rlon(npts),rlat(npts) + real(KIND=c_float),intent(out) :: crot(npts),srot(npts),xlon(npts),xlat(npts) + real(KIND=c_float),intent(out) :: ylon(npts),ylat(npts),area(npts) #else - real(KIND=c_double), value, intent(in) :: fill - real(KIND=c_double), intent(inout) :: xpts(npts), ypts(npts), rlon(npts), rlat(npts) - real(KIND=c_double), intent(out) :: crot(npts), srot(npts), xlon(npts), xlat(npts) - real(KIND=c_double), intent(out) :: ylon(npts), ylat(npts), area(npts) + real(KIND=c_double),value,intent(in) :: fill + real(KIND=c_double),intent(inout) :: xpts(npts),ypts(npts),rlon(npts),rlat(npts) + real(KIND=c_double),intent(out) :: crot(npts),srot(npts),xlon(npts),xlat(npts) + real(KIND=c_double),intent(out) :: ylon(npts),ylat(npts),area(npts) #endif - call gdswzd(kgds, iopt, npts, fill, xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + call gdswzd(kgds,iopt,npts,fill,xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) - end subroutine gdswzd_c_grib1 + endsubroutine gdswzd_c_grib1 -end module gdswzd_c_mod +endmodule gdswzd_c_mod diff --git a/src/gdswzd_mod.F90 b/src/gdswzd_mod.F90 index cdf0d6d2..92179a07 100644 --- a/src/gdswzd_mod.F90 +++ b/src/gdswzd_mod.F90 @@ -32,7 +32,7 @@ module gdswzd_mod private - public :: gdswzd_2d_array_grib1, gdswzd_grib1, gdswzd + public :: gdswzd_2d_array_grib1,gdswzd_grib1,gdswzd interface gdswzd module procedure gdswzd_1d_array @@ -41,7 +41,7 @@ module gdswzd_mod module procedure gdswzd_grib1 module procedure gdswzd_2d_array_grib1 module procedure gdswzd_grid - end interface gdswzd + endinterface gdswzd contains @@ -102,101 +102,101 @@ module gdswzd_mod !! !! @author Kyle Gerheiser !! @date July 2021 - subroutine gdswzd_grid(grid, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + subroutine gdswzd_grid(grid,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) - class(ip_grid), intent(in) :: grid - integer, intent(in) :: iopt, npts - integer, intent(out) :: nret + class(ip_grid),intent(in) :: grid + integer,intent(in) :: iopt,npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(npts), rlat(npts) - real, intent(inout) :: xpts(npts), ypts(npts) - real, optional, intent(out) :: crot(npts), srot(npts) - real, optional, intent(out) :: xlon(npts), xlat(npts) - real, optional, intent(out) :: ylon(npts), ylat(npts), area(npts) + real,intent(in) :: fill + real,intent(inout) :: rlon(npts),rlat(npts) + real,intent(inout) :: xpts(npts),ypts(npts) + real,optional,intent(out) :: crot(npts),srot(npts) + real,optional,intent(out) :: xlon(npts),xlat(npts) + real,optional,intent(out) :: ylon(npts),ylat(npts),area(npts) - integer :: is1, im, jm, nm, kscan, nscan, n - integer :: iopf, nn, i, j + integer :: is1,im,jm,nm,kscan,nscan,n + integer :: iopf,nn,i,j ! COMPUTE GRID COORDINATES FOR ALL GRID POINTS - if (iopt .eq. 0) then - iopf = 1 + if(iopt.eq.0) then + iopf=1 - if (grid%descriptor%grid_num .eq. -1) then - nm = npts + if(grid%descriptor%grid_num.eq.-1) then + nm=npts else - im = grid%im - jm = grid%jm - nm = im*jm - end if - nscan = grid%nscan - kscan = grid%kscan - - if (nm .gt. npts) then - rlat = fill - rlon = fill - xpts = fill - ypts = fill + im=grid%im + jm=grid%jm + nm=im*jm + endif + nscan=grid%nscan + kscan=grid%kscan + + if(nm.gt.npts) then + rlat=fill + rlon=fill + xpts=fill + ypts=fill return - end if + endif - select type (grid) - type is (ip_rot_equid_cylind_egrid) - if (kscan .eq. 0) then - is1 = (jm+1)/2 + select type(grid) + type is(ip_rot_equid_cylind_egrid) + if(kscan.eq.0) then + is1=(jm+1)/2 else - is1 = jm/2 - end if + is1=jm/2 + endif - do n = 1, nm - if (nscan .eq. 0) then - j = (n-1)/im+1 - i = (n-im*(j-1))*2-mod(j+kscan, 2) + do n=1,nm + if(nscan.eq.0) then + j=(n-1)/im+1 + i=(n-im*(j-1))*2-mod(j+kscan,2) else - nn = (n*2)-1+kscan - i = (nn-1)/jm+1 - j = mod(nn-1, jm)+1 - if (mod(jm, 2) .eq. 0 .and. mod(i, 2) .eq. 0 .and. kscan .eq. 0) j = j+1 - if (mod(jm, 2) .eq. 0 .and. mod(i, 2) .eq. 0 .and. kscan .eq. 1) j = j-1 - end if - xpts(n) = is1+(i-(j-kscan))/2 - ypts(n) = (i+(j-kscan))/2 - end do - type is (ip_station_points_grid) - do n = 1, nm - xpts(n) = fill - ypts(n) = fill - end do + nn=(n*2)-1+kscan + i=(nn-1)/jm+1 + j=mod(nn-1,jm)+1 + if(mod(jm,2).eq.0.and.mod(i,2).eq.0.and.kscan.eq.0) j=j+1 + if(mod(jm,2).eq.0.and.mod(i,2).eq.0.and.kscan.eq.1) j=j-1 + endif + xpts(n)=is1+(i-(j-kscan))/2 + ypts(n)=(i+(j-kscan))/2 + enddo + type is(ip_station_points_grid) + do n=1,nm + xpts(n)=fill + ypts(n)=fill + enddo class default - do n = 1, nm - if (nscan .eq. 0) then - j = (n-1)/im+1 - i = n-im*(j-1) + do n=1,nm + if(nscan.eq.0) then + j=(n-1)/im+1 + i=n-im*(j-1) else - i = (n-1)/jm+1 - j = n-jm*(i-1) - end if - xpts(n) = i - ypts(n) = j - end do - end select - - do n = nm+1, npts - xpts(n) = fill - ypts(n) = fill - end do + i=(n-1)/jm+1 + j=n-jm*(i-1) + endif + xpts(n)=i + ypts(n)=j + enddo + endselect + + do n=nm+1,npts + xpts(n)=fill + ypts(n)=fill + enddo else ! IOPT /= 0 - iopf = iopt - end if ! IOPT CHECK + iopf=iopt + endif ! IOPT CHECK - call grid%gdswzd(iopf, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + call grid%gdswzd(iopf,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) - end subroutine gdswzd_grid + endsubroutine gdswzd_grid !> Decodes the grib 2 grid definition template and returns !! one of the following (for scalars): @@ -274,110 +274,110 @@ end subroutine gdswzd_grid !! !! @author George Gayno, Mark Iredell !! @date Jan 2015 - subroutine gdswzd_scalar(igdtnum, igdtmpl, igdtlen, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + subroutine gdswzd_scalar(igdtnum,igdtmpl,igdtlen,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) implicit none ! - integer, intent(in) :: igdtnum, igdtlen - integer, intent(in) :: igdtmpl(igdtlen) - integer, intent(in) :: iopt, npts - integer, intent(out) :: nret + integer,intent(in) :: igdtnum,igdtlen + integer,intent(in) :: igdtmpl(igdtlen) + integer,intent(in) :: iopt,npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon, rlat - real, intent(inout) :: xpts, ypts - real, optional, intent(out) :: crot, srot - real, optional, intent(out) :: xlon, xlat - real, optional, intent(out) :: ylon, ylat, area - - real :: rlona(1), rlata(1) - real :: xptsa(1), yptsa(1) - real :: crota(1), srota(1) - real :: xlona(1), xlata(1) - real :: ylona(1), ylata(1), areaa(1) - - rlona(1) = rlon - rlata(1) = rlat - xptsa(1) = xpts - yptsa(1) = ypts - - nret = 0 + real,intent(in) :: fill + real,intent(inout) :: rlon,rlat + real,intent(inout) :: xpts,ypts + real,optional,intent(out) :: crot,srot + real,optional,intent(out) :: xlon,xlat + real,optional,intent(out) :: ylon,ylat,area + + real :: rlona(1),rlata(1) + real :: xptsa(1),yptsa(1) + real :: crota(1),srota(1) + real :: xlona(1),xlata(1) + real :: ylona(1),ylata(1),areaa(1) + + rlona(1)=rlon + rlata(1)=rlat + xptsa(1)=xpts + yptsa(1)=ypts + + nret=0 ! CALL WITHOUT EXTRA FIELDS. - if (.not. present(crot) .and. & - .not. present(srot) .and. & - .not. present(xlon) .and. & - .not. present(xlat) .and. & - .not. present(ylon) .and. & - .not. present(ylat) .and. & - .not. present(area)) then + if(.not.present(crot).and. & + .not.present(srot).and. & + .not.present(xlon).and. & + .not.present(xlat).and. & + .not.present(ylon).and. & + .not.present(ylat).and. & + .not.present(area)) then - call gdswzd_1d_array(igdtnum, igdtmpl, igdtlen, iopt, npts, fill, & - xptsa, yptsa, rlona, rlata, nret) + call gdswzd_1d_array(igdtnum,igdtmpl,igdtlen,iopt,npts,fill, & + xptsa,yptsa,rlona,rlata,nret) - rlon = rlona(1) - rlat = rlata(1) - xpts = xptsa(1) - ypts = yptsa(1) + rlon=rlona(1) + rlat=rlata(1) + xpts=xptsa(1) + ypts=yptsa(1) - end if + endif ! MIMIC CALL TO OLD 'GDSWIZ' ROUTINES. - if (present(crot) .and. & - present(srot) .and. & - .not. present(xlon) .and. & - .not. present(xlat) .and. & - .not. present(ylon) .and. & - .not. present(ylat) .and. & - .not. present(area)) then + if(present(crot).and. & + present(srot).and. & + .not.present(xlon).and. & + .not.present(xlat).and. & + .not.present(ylon).and. & + .not.present(ylat).and. & + .not.present(area)) then - call gdswzd_1d_array(igdtnum, igdtmpl, igdtlen, iopt, npts, fill, & - xptsa, yptsa, rlona, rlata, nret, crota, srota) + call gdswzd_1d_array(igdtnum,igdtmpl,igdtlen,iopt,npts,fill, & + xptsa,yptsa,rlona,rlata,nret,crota,srota) - rlon = rlona(1) - rlat = rlata(1) - xpts = xptsa(1) - ypts = yptsa(1) - crot = crota(1) - srot = srota(1) + rlon=rlona(1) + rlat=rlata(1) + xpts=xptsa(1) + ypts=yptsa(1) + crot=crota(1) + srot=srota(1) - end if + endif ! MIMIC CALL TO OLD 'GDSWZD' ROUTINES. - if (present(crot) .and. & - present(srot) .and. & - present(xlon) .and. & - present(xlat) .and. & - present(ylon) .and. & - present(ylat) .and. & - present(area)) then - - call gdswzd_1d_array(igdtnum, igdtmpl, igdtlen, iopt, npts, fill, & - xptsa, yptsa, rlona, rlata, nret, & - crota, srota, xlona, xlata, ylona, ylata, areaa) - - rlon = rlona(1) - rlat = rlata(1) - xpts = xptsa(1) - ypts = yptsa(1) - crot = crota(1) - srot = srota(1) - xlon = xlona(1) - xlat = xlata(1) - ylon = ylona(1) - ylat = ylata(1) - area = areaa(1) - - end if + if(present(crot).and. & + present(srot).and. & + present(xlon).and. & + present(xlat).and. & + present(ylon).and. & + present(ylat).and. & + present(area)) then + + call gdswzd_1d_array(igdtnum,igdtmpl,igdtlen,iopt,npts,fill, & + xptsa,yptsa,rlona,rlata,nret, & + crota,srota,xlona,xlata,ylona,ylata,areaa) + + rlon=rlona(1) + rlat=rlata(1) + xpts=xptsa(1) + ypts=yptsa(1) + crot=crota(1) + srot=srota(1) + xlon=xlona(1) + xlat=xlata(1) + ylon=ylona(1) + ylat=ylata(1) + area=areaa(1) + + endif return - end subroutine gdswzd_scalar + endsubroutine gdswzd_scalar !> Decodes the grib 2 grid definition template and returns !! one of the following (for 2d-arrays): @@ -455,29 +455,29 @@ end subroutine gdswzd_scalar !! !! @author George Gayno, Mark Iredell !! @date Jan 2015 - subroutine gdswzd_2d_array(igdtnum, igdtmpl, igdtlen, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + subroutine gdswzd_2d_array(igdtnum,igdtmpl,igdtlen,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) implicit none ! - integer, intent(in) :: igdtnum, igdtlen - integer, intent(in) :: igdtmpl(igdtlen) - integer, intent(in) :: iopt, npts - integer, intent(out) :: nret + integer,intent(in) :: igdtnum,igdtlen + integer,intent(in) :: igdtmpl(igdtlen) + integer,intent(in) :: iopt,npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(:, :), rlat(:, :) - real, intent(inout) :: xpts(:, :), ypts(:, :) - real, optional, intent(out) :: crot(:, :), srot(:, :) - real, optional, intent(out) :: xlon(:, :), xlat(:, :) - real, optional, intent(out) :: ylon(:, :), ylat(:, :), area(:, :) + real,intent(in) :: fill + real,intent(inout) :: rlon(:,:),rlat(:,:) + real,intent(inout) :: xpts(:,:),ypts(:,:) + real,optional,intent(out) :: crot(:,:),srot(:,:) + real,optional,intent(out) :: xlon(:,:),xlat(:,:) + real,optional,intent(out) :: ylon(:,:),ylat(:,:),area(:,:) - call gdswzd_1d_array(igdtnum, igdtmpl, igdtlen, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + call gdswzd_1d_array(igdtnum,igdtmpl,igdtlen,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) - end subroutine gdswzd_2d_array + endsubroutine gdswzd_2d_array !> Decodes the grib 2 grid definition template and returns one of the following: !! - iopt=0 Grid and earth coordinates of all grid points. @@ -661,32 +661,32 @@ end subroutine gdswzd_2d_array !! !! @author George Gayno, Mark Iredell !! @date Jan 2015 - subroutine gdswzd_1d_array(igdtnum, igdtmpl, igdtlen, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) - integer, intent(in) :: igdtnum, igdtlen - integer, intent(in) :: igdtmpl(igdtlen) - integer, intent(in) :: iopt, npts - integer, intent(out) :: nret + subroutine gdswzd_1d_array(igdtnum,igdtmpl,igdtlen,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) + integer,intent(in) :: igdtnum,igdtlen + integer,intent(in) :: igdtmpl(igdtlen) + integer,intent(in) :: iopt,npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(npts), rlat(npts) - real, intent(inout) :: xpts(npts), ypts(npts) - real, optional, intent(out) :: crot(npts), srot(npts) - real, optional, intent(out) :: xlon(npts), xlat(npts) - real, optional, intent(out) :: ylon(npts), ylat(npts), area(npts) + real,intent(in) :: fill + real,intent(inout) :: rlon(npts),rlat(npts) + real,intent(inout) :: xpts(npts),ypts(npts) + real,optional,intent(out) :: crot(npts),srot(npts) + real,optional,intent(out) :: xlon(npts),xlat(npts) + real,optional,intent(out) :: ylon(npts),ylat(npts),area(npts) type(grib2_descriptor) :: desc - class(ip_grid), allocatable :: grid + class(ip_grid),allocatable :: grid - desc = init_descriptor(igdtnum, igdtlen, igdtmpl) - call init_grid(grid, desc) + desc=init_descriptor(igdtnum,igdtlen,igdtmpl) + call init_grid(grid,desc) - call gdswzd_grid(grid, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + call gdswzd_grid(grid,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) - end subroutine gdswzd_1d_array + endsubroutine gdswzd_1d_array !> Decodes the grib grid description section and !! returns one of the following (for 1-d arrays): @@ -754,29 +754,29 @@ end subroutine gdswzd_1d_array !! !! @author George Gayno, Mark Iredell !! @date April 1996 - subroutine gdswzd_grib1(kgds, iopt, npts, fill, xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) - integer, intent(in) :: iopt, kgds(200), npts - integer, intent(out) :: nret + subroutine gdswzd_grib1(kgds,iopt,npts,fill,xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) + integer,intent(in) :: iopt,kgds(200),npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(npts), rlat(npts) - real, intent(inout) :: xpts(npts), ypts(npts) - real, optional, intent(out) :: crot(npts), srot(npts) - real, optional, intent(out) :: xlon(npts), xlat(npts) - real, optional, intent(out) :: ylon(npts), ylat(npts), area(npts) + real,intent(in) :: fill + real,intent(inout) :: rlon(npts),rlat(npts) + real,intent(inout) :: xpts(npts),ypts(npts) + real,optional,intent(out) :: crot(npts),srot(npts) + real,optional,intent(out) :: xlon(npts),xlat(npts) + real,optional,intent(out) :: ylon(npts),ylat(npts),area(npts) type(grib1_descriptor) :: desc - class(ip_grid), allocatable :: grid + class(ip_grid),allocatable :: grid - desc = init_descriptor(kgds) - call init_grid(grid, desc) + desc=init_descriptor(kgds) + call init_grid(grid,desc) - call gdswzd_grid(grid, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + call gdswzd_grid(grid,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) - end subroutine gdswzd_grib1 + endsubroutine gdswzd_grib1 !> Decodes the grib grid description section and returns !! one of the following (for 2-d arrays): @@ -844,30 +844,30 @@ end subroutine gdswzd_grib1 !! !! @author George Gayno, Mark Iredell !! @date April 1996 - subroutine gdswzd_2d_array_grib1(kgds, iopt, npts, fill, xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + subroutine gdswzd_2d_array_grib1(kgds,iopt,npts,fill,xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) !$$$ - integer, intent(in) :: iopt, kgds(200), npts - integer, intent(out) :: nret + integer,intent(in) :: iopt,kgds(200),npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(:, :), rlat(:, :) - real, intent(inout) :: xpts(:, :), ypts(:, :) - real, optional, intent(out) :: crot(:, :), srot(:, :) - real, optional, intent(out) :: xlon(:, :), xlat(:, :) - real, optional, intent(out) :: ylon(:, :), ylat(:, :), area(:, :) + real,intent(in) :: fill + real,intent(inout) :: rlon(:,:),rlat(:,:) + real,intent(inout) :: xpts(:,:),ypts(:,:) + real,optional,intent(out) :: crot(:,:),srot(:,:) + real,optional,intent(out) :: xlon(:,:),xlat(:,:) + real,optional,intent(out) :: ylon(:,:),ylat(:,:),area(:,:) type(grib1_descriptor) :: desc - class(ip_grid), allocatable :: grid + class(ip_grid),allocatable :: grid - desc = init_descriptor(kgds) - call init_grid(grid, desc) + desc=init_descriptor(kgds) + call init_grid(grid,desc) - call gdswzd_grid(grid, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + call gdswzd_grid(grid,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) - end subroutine gdswzd_2d_array_grib1 + endsubroutine gdswzd_2d_array_grib1 -end module gdswzd_mod +endmodule gdswzd_mod diff --git a/src/ip_constants_mod.F90 b/src/ip_constants_mod.F90 index b300d158..de2ad9e4 100644 --- a/src/ip_constants_mod.F90 +++ b/src/ip_constants_mod.F90 @@ -11,12 +11,12 @@ module ip_constants_mod public - real, parameter :: pi = 3.14159265358979 !< PI - real, parameter :: dpr = 180.0/pi !< Radians to degrees - real, parameter :: pi2 = pi/2.0 !< PI / 2.0 - real, parameter :: pi4 = pi/4.0 !< PI / 4.0 - real, parameter :: rerth_wgs84 = 6.378137e6 !< Radius of the Earth defined by WGS-84 - real, parameter :: e2_wgs84 = 0.00669437999013 !< Eccentricity squared of Earth defined by WGS-84 + real,parameter :: pi=3.14159265358979 !< PI + real,parameter :: dpr=180.0/pi !< Radians to degrees + real,parameter :: pi2=pi/2.0 !< PI / 2.0 + real,parameter :: pi4=pi/4.0 !< PI / 4.0 + real,parameter :: rerth_wgs84=6.378137e6 !< Radius of the Earth defined by WGS-84 + real,parameter :: e2_wgs84=0.00669437999013 !< Eccentricity squared of Earth defined by WGS-84 -end module ip_constants_mod +endmodule ip_constants_mod diff --git a/src/ip_equid_cylind_grid_mod.F90 b/src/ip_equid_cylind_grid_mod.F90 index 21183b23..9573d99e 100644 --- a/src/ip_equid_cylind_grid_mod.F90 +++ b/src/ip_equid_cylind_grid_mod.F90 @@ -23,7 +23,7 @@ module ip_equid_cylind_grid_mod private public :: ip_equid_cylind_grid - type, extends(ip_grid) :: ip_equid_cylind_grid + type,extends(ip_grid) :: ip_equid_cylind_grid real :: hi !< Scan mode in the 'i' direction. GRIB2, Section 3, octet 72. real :: rlat1 !< Latitude of first grid point. GRIB2, Section 3, octets 47-50. real :: rlon1 !< Longitude of first grid point. GRIB2, Section 3, octets 51-54. @@ -34,8 +34,8 @@ module ip_equid_cylind_grid_mod contains procedure :: init_grib1 !< Init GRIB1. @return N/A procedure :: init_grib2 !< Init GRIB2. @return N/A - procedure :: gdswzd => gdswzd_equid_cylind !< See gdswzd_equid_cylind(). @return N/A - end type ip_equid_cylind_grid + procedure :: gdswzd=>gdswzd_equid_cylind !< See gdswzd_equid_cylind(). @return N/A + endtype ip_equid_cylind_grid real :: dlat !< Grid resolution in degrees n/s direction. real :: dlon !< Grid resolution in degrees e/w direction. @@ -50,55 +50,55 @@ module ip_equid_cylind_grid_mod !! !! @author Kyle Gerheiser !! @date July 2021 - subroutine init_grib1(self, g1_desc) - class(ip_equid_cylind_grid), intent(inout) :: self - type(grib1_descriptor), intent(in) :: g1_desc + subroutine init_grib1(self,g1_desc) + class(ip_equid_cylind_grid),intent(inout) :: self + type(grib1_descriptor),intent(in) :: g1_desc integer :: iscan - associate (kgds => g1_desc%gds) - self%im = kgds(2) - self%jm = kgds(3) - self%rlat1 = kgds(4)*1.e-3 - self%rlon1 = kgds(5)*1.e-3 - self%rlat2 = kgds(7)*1.e-3 - self%rlon2 = kgds(8)*1.e-3 - iscan = mod(kgds(11)/128, 2) - self%hi = (-1.)**iscan - self%dlon = self%hi*(mod(self%hi*(self%rlon2-self%rlon1)-1+3600, 360.)+1)/(self%im-1) - self%dlat = (self%rlat2-self%rlat1)/(self%jm-1) + associate(kgds=>g1_desc%gds) + self%im=kgds(2) + self%jm=kgds(3) + self%rlat1=kgds(4)*1.e-3 + self%rlon1=kgds(5)*1.e-3 + self%rlat2=kgds(7)*1.e-3 + self%rlon2=kgds(8)*1.e-3 + iscan=mod(kgds(11)/128,2) + self%hi=(-1.)**iscan + self%dlon=self%hi*(mod(self%hi*(self%rlon2-self%rlon1)-1+3600,360.)+1)/(self%im-1) + self%dlat=(self%rlat2-self%rlat1)/(self%jm-1) ! defaults - self%iwrap = 0 - self%jwrap1 = 0 - self%jwrap2 = 0 - self%nscan = mod(kgds(11)/32, 2) - self%nscan_field_pos = self%nscan - self%kscan = 0 - - self%iwrap = nint(360/abs(self%dlon)) - - if (self%im .lt. self%iwrap) self%iwrap = 0 - self%jwrap1 = 0 - self%jwrap2 = 0 - if (self%iwrap .gt. 0 .and. mod(self%iwrap, 2) .eq. 0) then - if (abs(self%rlat1) .gt. 90-0.25*self%dlat) then - self%jwrap1 = 2 - elseif (abs(self%rlat1) .gt. 90-0.75*self%dlat) then - self%jwrap1 = 1 - end if - if (abs(self%rlat2) .gt. 90-0.25*self%dlat) then - self%jwrap2 = 2*self%jm - elseif (abs(self%rlat2) .gt. 90-0.75*self%dlat) then - self%jwrap2 = 2*self%jm+1 - end if - end if - - self%rerth = 6.3712e6 - self%eccen_squared = 0.0 - end associate - - end subroutine init_grib1 + self%iwrap=0 + self%jwrap1=0 + self%jwrap2=0 + self%nscan=mod(kgds(11)/32,2) + self%nscan_field_pos=self%nscan + self%kscan=0 + + self%iwrap=nint(360/abs(self%dlon)) + + if(self%im.lt.self%iwrap) self%iwrap=0 + self%jwrap1=0 + self%jwrap2=0 + if(self%iwrap.gt.0.and.mod(self%iwrap,2).eq.0) then + if(abs(self%rlat1).gt.90-0.25*self%dlat) then + self%jwrap1=2 + elseif(abs(self%rlat1).gt.90-0.75*self%dlat) then + self%jwrap1=1 + endif + if(abs(self%rlat2).gt.90-0.25*self%dlat) then + self%jwrap2=2*self%jm + elseif(abs(self%rlat2).gt.90-0.75*self%dlat) then + self%jwrap2=2*self%jm+1 + endif + endif + + self%rerth=6.3712e6 + self%eccen_squared=0.0 + endassociate + + endsubroutine init_grib1 !> Initializes an equidistant cylindrical grid given a grib2_descriptor object. !! @param[inout] self The grid to initialize @@ -106,55 +106,55 @@ end subroutine init_grib1 !! !! @author Kyle Gerheiser !! @date July 2021 - subroutine init_grib2(self, g2_desc) - class(ip_equid_cylind_grid), intent(inout) :: self - type(grib2_descriptor), intent(in) :: g2_desc - - integer :: iscale, iscan - - associate (igdtmpl => g2_desc%gdt_tmpl, igdtlen => g2_desc%gdt_len) - self%im = igdtmpl(8) - self%jm = igdtmpl(9) - iscale = igdtmpl(10)*igdtmpl(11) - if (iscale .eq. 0) iscale = 10**6 - self%rlat1 = float(igdtmpl(12))/float(iscale) - self%rlon1 = float(igdtmpl(13))/float(iscale) - self%rlat2 = float(igdtmpl(15))/float(iscale) - self%rlon2 = float(igdtmpl(16))/float(iscale) - iscan = mod(igdtmpl(19)/128, 2) - self%hi = (-1.)**iscan - self%dlon = self%hi*(mod(self%hi*(self%rlon2-self%rlon1)-1+3600, 360.)+1)/(self%im-1) - self%dlat = (self%rlat2-self%rlat1)/(self%jm-1) - - self%nscan = mod(igdtmpl(19)/32, 2) - self%nscan_field_pos = self%nscan - self%kscan = 0 - self%iwrap = nint(360/abs(self%dlon)) - - if (self%im .lt. self%iwrap) self%iwrap = 0 - self%jwrap1 = 0 - self%jwrap2 = 0 - - if (self%im .lt. self%iwrap) self%iwrap = 0 - self%jwrap1 = 0 - self%jwrap2 = 0 - if (self%iwrap .gt. 0 .and. mod(self%iwrap, 2) .eq. 0) then - if (abs(self%rlat1) .gt. 90-0.25*self%dlat) then - self%jwrap1 = 2 - elseif (abs(self%rlat1) .gt. 90-0.75*self%dlat) then - self%jwrap1 = 1 - end if - if (abs(self%rlat2) .gt. 90-0.25*self%dlat) then - self%jwrap2 = 2*self%jm - elseif (abs(self%rlat2) .gt. 90-0.75*self%dlat) then - self%jwrap2 = 2*self%jm+1 - end if - end if - - call earth_radius(igdtmpl, igdtlen, self%rerth, self%eccen_squared) - - end associate - end subroutine init_grib2 + subroutine init_grib2(self,g2_desc) + class(ip_equid_cylind_grid),intent(inout) :: self + type(grib2_descriptor),intent(in) :: g2_desc + + integer :: iscale,iscan + + associate(igdtmpl=>g2_desc%gdt_tmpl,igdtlen=>g2_desc%gdt_len) + self%im=igdtmpl(8) + self%jm=igdtmpl(9) + iscale=igdtmpl(10)*igdtmpl(11) + if(iscale.eq.0) iscale=10**6 + self%rlat1=float(igdtmpl(12))/float(iscale) + self%rlon1=float(igdtmpl(13))/float(iscale) + self%rlat2=float(igdtmpl(15))/float(iscale) + self%rlon2=float(igdtmpl(16))/float(iscale) + iscan=mod(igdtmpl(19)/128,2) + self%hi=(-1.)**iscan + self%dlon=self%hi*(mod(self%hi*(self%rlon2-self%rlon1)-1+3600,360.)+1)/(self%im-1) + self%dlat=(self%rlat2-self%rlat1)/(self%jm-1) + + self%nscan=mod(igdtmpl(19)/32,2) + self%nscan_field_pos=self%nscan + self%kscan=0 + self%iwrap=nint(360/abs(self%dlon)) + + if(self%im.lt.self%iwrap) self%iwrap=0 + self%jwrap1=0 + self%jwrap2=0 + + if(self%im.lt.self%iwrap) self%iwrap=0 + self%jwrap1=0 + self%jwrap2=0 + if(self%iwrap.gt.0.and.mod(self%iwrap,2).eq.0) then + if(abs(self%rlat1).gt.90-0.25*self%dlat) then + self%jwrap1=2 + elseif(abs(self%rlat1).gt.90-0.75*self%dlat) then + self%jwrap1=1 + endif + if(abs(self%rlat2).gt.90-0.25*self%dlat) then + self%jwrap2=2*self%jm + elseif(abs(self%rlat2).gt.90-0.75*self%dlat) then + self%jwrap2=2*self%jm+1 + endif + endif + + call earth_radius(igdtmpl,igdtlen,self%rerth,self%eccen_squared) + + endassociate + endsubroutine init_grib2 !> Calculates Earth coordinates (iopt = 1) or grid coorindates (iopt = -1) !! for equidistant cylindrical grids. @@ -200,117 +200,117 @@ end subroutine init_grib2 !! !! @author Mark Iredell, George Gayno, Kyle Gerheiser !! @date July 2021 - subroutine gdswzd_equid_cylind(self, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + subroutine gdswzd_equid_cylind(self,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) implicit none ! - class(ip_equid_cylind_grid), intent(in) :: self - integer, intent(in) :: iopt, npts - integer, intent(out) :: nret + class(ip_equid_cylind_grid),intent(in) :: self + integer,intent(in) :: iopt,npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(npts), rlat(npts) - real, intent(inout) :: xpts(npts), ypts(npts) - real, optional, intent(out) :: crot(npts), srot(npts) - real, optional, intent(out) :: xlon(npts), xlat(npts) - real, optional, intent(out) :: ylon(npts), ylat(npts), area(npts) + real,intent(in) :: fill + real,intent(inout) :: rlon(npts),rlat(npts) + real,intent(inout) :: xpts(npts),ypts(npts) + real,optional,intent(out) :: crot(npts),srot(npts) + real,optional,intent(out) :: xlon(npts),xlat(npts) + real,optional,intent(out) :: ylon(npts),ylat(npts),area(npts) ! - integer :: im, jm, n + integer :: im,jm,n ! - logical :: lrot, lmap, larea + logical :: lrot,lmap,larea ! - real :: hi, rlat1, rlon1, rlat2, rlon2 - real :: xmax, xmin, ymax, ymin + real :: hi,rlat1,rlon1,rlat2,rlon2 + real :: xmax,xmin,ymax,ymin ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (present(crot)) crot = fill - if (present(srot)) srot = fill - if (present(xlon)) xlon = fill - if (present(xlat)) xlat = fill - if (present(ylon)) ylon = fill - if (present(ylat)) ylat = fill - if (present(area)) area = fill - - im = self%im - jm = self%jm - - rlat1 = self%rlat1 - rlon1 = self%rlon1 - rlat2 = self%rlat2 - rlon2 = self%rlon2 - - hi = self%hi - - rerth = self%rerth - dlat = self%dlat - dlon = self%dlon - - xmin = 0 - xmax = im+1 - if (im .eq. nint(360/abs(dlon))) xmax = im+2 - ymin = 0 - ymax = jm+1 - nret = 0 - if (present(crot) .and. present(srot)) then - lrot = .true. + if(present(crot)) crot=fill + if(present(srot)) srot=fill + if(present(xlon)) xlon=fill + if(present(xlat)) xlat=fill + if(present(ylon)) ylon=fill + if(present(ylat)) ylat=fill + if(present(area)) area=fill + + im=self%im + jm=self%jm + + rlat1=self%rlat1 + rlon1=self%rlon1 + rlat2=self%rlat2 + rlon2=self%rlon2 + + hi=self%hi + + rerth=self%rerth + dlat=self%dlat + dlon=self%dlon + + xmin=0 + xmax=im+1 + if(im.eq.nint(360/abs(dlon))) xmax=im+2 + ymin=0 + ymax=jm+1 + nret=0 + if(present(crot).and.present(srot)) then + lrot=.true. else - lrot = .false. - end if - if (present(xlon) .and. present(xlat) .and. present(ylon) .and. present(ylat)) then - lmap = .true. + lrot=.false. + endif + if(present(xlon).and.present(xlat).and.present(ylon).and.present(ylat)) then + lmap=.true. else - lmap = .false. - end if - if (present(area)) then - larea = .true. + lmap=.false. + endif + if(present(area)) then + larea=.true. else - larea = .false. - end if + larea=.false. + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSLATE GRID COORDINATES TO EARTH COORDINATES - if (iopt .eq. 0 .or. iopt .eq. 1) then + if(iopt.eq.0.or.iopt.eq.1) then !$omp parallel do private(n) reduction(+:nret) schedule(static) - do n = 1, npts - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - rlon(n) = mod(rlon1+dlon*(xpts(n)-1)+3600, 360.) - rlat(n) = min(max(rlat1+dlat*(ypts(n)-1), -90.), 90.) - nret = nret+1 - if (lrot) call equid_cylind_vect_rot(crot(n), srot(n)) - if (lmap) call equid_cylind_map_jacob(xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call equid_cylind_grid_area(rlat(n), area(n)) + do n=1,npts + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + rlon(n)=mod(rlon1+dlon*(xpts(n)-1)+3600,360.) + rlat(n)=min(max(rlat1+dlat*(ypts(n)-1),-90.),90.) + nret=nret+1 + if(lrot) call equid_cylind_vect_rot(crot(n),srot(n)) + if(lmap) call equid_cylind_map_jacob(xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call equid_cylind_grid_area(rlat(n),area(n)) else - rlon(n) = fill - rlat(n) = fill - end if - end do + rlon(n)=fill + rlat(n)=fill + endif + enddo !$omp end parallel do ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSLATE EARTH COORDINATES TO GRID COORDINATES - elseif (iopt .eq. -1) then + elseif(iopt.eq.-1) then !$omp parallel do private(n) reduction(+:nret) schedule(static) - do n = 1, npts - if (abs(rlon(n)) .le. 360 .and. abs(rlat(n)) .le. 90) then - xpts(n) = 1+hi*mod(hi*(rlon(n)-rlon1)+3600, 360.)/dlon - ypts(n) = 1+(rlat(n)-rlat1)/dlat - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - nret = nret+1 - if (lrot) call equid_cylind_vect_rot(crot(n), srot(n)) - if (lmap) call equid_cylind_map_jacob(xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call equid_cylind_grid_area(rlat(n), area(n)) + do n=1,npts + if(abs(rlon(n)).le.360.and.abs(rlat(n)).le.90) then + xpts(n)=1+hi*mod(hi*(rlon(n)-rlon1)+3600,360.)/dlon + ypts(n)=1+(rlat(n)-rlat1)/dlat + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + nret=nret+1 + if(lrot) call equid_cylind_vect_rot(crot(n),srot(n)) + if(lmap) call equid_cylind_map_jacob(xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call equid_cylind_grid_area(rlat(n),area(n)) else - xpts(n) = fill - ypts(n) = fill - end if + xpts(n)=fill + ypts(n)=fill + endif else - xpts(n) = fill - ypts(n) = fill - end if - end do + xpts(n)=fill + ypts(n)=fill + endif + enddo !$omp end parallel do - end if - end subroutine gdswzd_equid_cylind + endif + endsubroutine gdswzd_equid_cylind !> Computes the vector rotation sines and !! cosines for a equidistant cylindrical grid. @@ -324,15 +324,15 @@ end subroutine gdswzd_equid_cylind !! !! @author George Gayno !! @date July 2021 - subroutine equid_cylind_vect_rot(crot, srot) + subroutine equid_cylind_vect_rot(crot,srot) implicit none - real, intent(out) :: crot, srot + real,intent(out) :: crot,srot - crot = 1.0 - srot = 0.0 + crot=1.0 + srot=0.0 - end subroutine equid_cylind_vect_rot + endsubroutine equid_cylind_vect_rot !> Computes the map jacobians for a equidistant cylindrical grid. !! @@ -343,15 +343,15 @@ end subroutine equid_cylind_vect_rot !! !! @author George Gayno !! @date July 2021 - subroutine equid_cylind_map_jacob(xlon, xlat, ylon, ylat) - real, intent(out) :: xlon, xlat, ylon, ylat + subroutine equid_cylind_map_jacob(xlon,xlat,ylon,ylat) + real,intent(out) :: xlon,xlat,ylon,ylat - xlon = 1.0/dlon - xlat = 0. - ylon = 0. - ylat = 1.0/dlat + xlon=1.0/dlon + xlat=0. + ylon=0. + ylat=1.0/dlat - end subroutine equid_cylind_map_jacob + endsubroutine equid_cylind_map_jacob !> Computes the grid box area for a equidistant cylindrical grid. !! @@ -360,23 +360,23 @@ end subroutine equid_cylind_map_jacob !! !! @author Mark Iredell, George Gayno !! @date July 2021 - subroutine equid_cylind_grid_area(rlat, area) + subroutine equid_cylind_grid_area(rlat,area) implicit none - real, intent(in) :: rlat - real, intent(out) :: area + real,intent(in) :: rlat + real,intent(out) :: area - real, parameter :: pi = 3.14159265358979 - real, parameter :: dpr = 180./pi + real,parameter :: pi=3.14159265358979 + real,parameter :: dpr=180./pi - real :: dslat, rlatu, rlatd + real :: dslat,rlatu,rlatd - rlatu = min(max(rlat+dlat/2, -90.), 90.) - rlatd = min(max(rlat-dlat/2, -90.), 90.) - dslat = sin(rlatu/dpr)-sin(rlatd/dpr) - area = rerth**2*abs(dslat*dlon)/dpr + rlatu=min(max(rlat+dlat/2,-90.),90.) + rlatd=min(max(rlat-dlat/2,-90.),90.) + dslat=sin(rlatu/dpr)-sin(rlatd/dpr) + area=rerth**2*abs(dslat*dlon)/dpr - end subroutine equid_cylind_grid_area + endsubroutine equid_cylind_grid_area -end module ip_equid_cylind_grid_mod +endmodule ip_equid_cylind_grid_mod diff --git a/src/ip_gaussian_grid_mod.F90 b/src/ip_gaussian_grid_mod.F90 index f105099b..46bfca0a 100644 --- a/src/ip_gaussian_grid_mod.F90 +++ b/src/ip_gaussian_grid_mod.F90 @@ -22,7 +22,7 @@ module ip_gaussian_grid_mod private public :: ip_gaussian_grid - type, extends(ip_grid) :: ip_gaussian_grid + type,extends(ip_grid) :: ip_gaussian_grid integer :: jh !< Scan mode flag in 'j' direction. When '1' points scan from N to S. When "-1" points scan from S to N. real :: dlon !< "i"-direction increment. GRIB2 Section 3, octets 64-67. real :: rlat1 !< Latitude of first grid point. GRIB2 Section 3, octets 47-50. @@ -38,15 +38,15 @@ module ip_gaussian_grid_mod procedure :: init_grib2 !> Calculates Earth coordinates (iopt = 1) or grid coorindates (iopt = -1) !> for Gaussian grids. @return N/A - procedure :: gdswzd => gdswzd_gaussian - end type ip_gaussian_grid + procedure :: gdswzd=>gdswzd_gaussian + endtype ip_gaussian_grid integer :: j1 !< 'j' index of first grid point within the global array of latitudes. integer :: jh !< Scan mode flag in 'j' direction. When '1' points scan from N to S. When "-1" points scan from S to N. - real, allocatable :: blat(:) !< Gaussian latitude for each parallel. + real,allocatable :: blat(:) !< Gaussian latitude for each parallel. real :: dlon !< "i"-direction increment. GRIB2 Section 3, octets 64-67. real :: rerth !< Radius of the earth. GRIB2 Section 3, octets 15-30. - real, allocatable :: ylat_row(:) !< dy/dlat for each row in 1/degrees. + real,allocatable :: ylat_row(:) !< dy/dlat for each row in 1/degrees. contains @@ -57,48 +57,48 @@ module ip_gaussian_grid_mod !> !> @author Kyle Gerheiser !> @date July 2021 - subroutine init_grib1(self, g1_desc) - class(ip_gaussian_grid), intent(inout) :: self - type(grib1_descriptor), intent(in) :: g1_desc - - integer :: iscan, jg - - associate (kgds => g1_desc%gds) - self%rerth = 6.3712e6 - self%eccen_squared = 0.0 - - self%im = kgds(2) - self%jm = kgds(3) - self%rlat1 = kgds(4)*1.e-3 - self%rlon1 = kgds(5)*1.e-3 - self%rlon2 = kgds(8)*1.e-3 - self%jg = kgds(10)*2 - iscan = mod(kgds(11)/128, 2) - self%jscan = mod(kgds(11)/64, 2) - self%hi = (-1.)**iscan - self%jh = (-1)**self%jscan - self%dlon = self%hi*(mod(self%hi*(self%rlon2-self%rlon1)-1+3600, 360.)+1)/(self%im-1) - - self%iwrap = 0 - self%jwrap1 = 0 - self%jwrap2 = 0 - self%nscan = mod(kgds(11)/32, 2) - self%nscan_field_pos = self%nscan - self%kscan = 0 - - self%iwrap = nint(360/abs(self%dlon)) - if (self%im .lt. self%iwrap) self%iwrap = 0 - - if (self%iwrap .gt. 0 .and. mod(self%iwrap, 2) .eq. 0) then - jg = kgds(10)*2 - if (self%jm .eq. self%jg) then - self%jwrap1 = 1 - self%jwrap2 = 2*self%jm+1 - end if - end if - - end associate - end subroutine init_grib1 + subroutine init_grib1(self,g1_desc) + class(ip_gaussian_grid),intent(inout) :: self + type(grib1_descriptor),intent(in) :: g1_desc + + integer :: iscan,jg + + associate(kgds=>g1_desc%gds) + self%rerth=6.3712e6 + self%eccen_squared=0.0 + + self%im=kgds(2) + self%jm=kgds(3) + self%rlat1=kgds(4)*1.e-3 + self%rlon1=kgds(5)*1.e-3 + self%rlon2=kgds(8)*1.e-3 + self%jg=kgds(10)*2 + iscan=mod(kgds(11)/128,2) + self%jscan=mod(kgds(11)/64,2) + self%hi=(-1.)**iscan + self%jh=(-1)**self%jscan + self%dlon=self%hi*(mod(self%hi*(self%rlon2-self%rlon1)-1+3600,360.)+1)/(self%im-1) + + self%iwrap=0 + self%jwrap1=0 + self%jwrap2=0 + self%nscan=mod(kgds(11)/32,2) + self%nscan_field_pos=self%nscan + self%kscan=0 + + self%iwrap=nint(360/abs(self%dlon)) + if(self%im.lt.self%iwrap) self%iwrap=0 + + if(self%iwrap.gt.0.and.mod(self%iwrap,2).eq.0) then + jg=kgds(10)*2 + if(self%jm.eq.self%jg) then + self%jwrap1=1 + self%jwrap2=2*self%jm+1 + endif + endif + + endassociate + endsubroutine init_grib1 !> Initializes a gaussian grid given a grib2_descriptor object. !> @param[inout] self The grid to initialize @@ -106,46 +106,46 @@ end subroutine init_grib1 !> !> @author Kyle Gerheiser !> @date July 2021 - subroutine init_grib2(self, g2_desc) - class(ip_gaussian_grid), intent(inout) :: self - type(grib2_descriptor), intent(in) :: g2_desc - - integer :: iscale, iscan, jg - - associate (igdtmpl => g2_desc%gdt_tmpl, igdtlen => g2_desc%gdt_len) - call earth_radius(igdtmpl, igdtlen, self%rerth, self%eccen_squared) - - self%im = igdtmpl(8) - self%jm = igdtmpl(9) - iscale = igdtmpl(10)*igdtmpl(11) - if (iscale .eq. 0) iscale = 10**6 - self%rlat1 = float(igdtmpl(12))/float(iscale) - self%rlon1 = float(igdtmpl(13))/float(iscale) - self%rlon2 = float(igdtmpl(16))/float(iscale) - self%jg = igdtmpl(18)*2 - iscan = mod(igdtmpl(19)/128, 2) - self%jscan = mod(igdtmpl(19)/64, 2) - self%hi = (-1.)**iscan - self%jh = (-1)**self%jscan - self%dlon = self%hi*(mod(self%hi*(self%rlon2-self%rlon1)-1+3600, 360.)+1)/(self%im-1) - - self%iwrap = nint(360/abs(self%dlon)) - if (self%im .lt. self%iwrap) self%iwrap = 0 - self%jwrap1 = 0 - self%jwrap2 = 0 - if (self%iwrap .gt. 0 .and. mod(self%iwrap, 2) .eq. 0) then - jg = igdtmpl(18)*2 - if (self%jm .eq. jg) then - self%jwrap1 = 1 - self%jwrap2 = 2*self%jm+1 - end if - end if - self%nscan = mod(igdtmpl(19)/32, 2) - self%nscan_field_pos = self%nscan - self%kscan = 0 - end associate - - end subroutine init_grib2 + subroutine init_grib2(self,g2_desc) + class(ip_gaussian_grid),intent(inout) :: self + type(grib2_descriptor),intent(in) :: g2_desc + + integer :: iscale,iscan,jg + + associate(igdtmpl=>g2_desc%gdt_tmpl,igdtlen=>g2_desc%gdt_len) + call earth_radius(igdtmpl,igdtlen,self%rerth,self%eccen_squared) + + self%im=igdtmpl(8) + self%jm=igdtmpl(9) + iscale=igdtmpl(10)*igdtmpl(11) + if(iscale.eq.0) iscale=10**6 + self%rlat1=float(igdtmpl(12))/float(iscale) + self%rlon1=float(igdtmpl(13))/float(iscale) + self%rlon2=float(igdtmpl(16))/float(iscale) + self%jg=igdtmpl(18)*2 + iscan=mod(igdtmpl(19)/128,2) + self%jscan=mod(igdtmpl(19)/64,2) + self%hi=(-1.)**iscan + self%jh=(-1)**self%jscan + self%dlon=self%hi*(mod(self%hi*(self%rlon2-self%rlon1)-1+3600,360.)+1)/(self%im-1) + + self%iwrap=nint(360/abs(self%dlon)) + if(self%im.lt.self%iwrap) self%iwrap=0 + self%jwrap1=0 + self%jwrap2=0 + if(self%iwrap.gt.0.and.mod(self%iwrap,2).eq.0) then + jg=igdtmpl(18)*2 + if(self%jm.eq.jg) then + self%jwrap1=1 + self%jwrap2=2*self%jm+1 + endif + endif + self%nscan=mod(igdtmpl(19)/32,2) + self%nscan_field_pos=self%nscan + self%kscan=0 + endassociate + + endsubroutine init_grib2 !> Calculates Earth coordinates (iopt = 1) or grid coorindates (iopt = -1) !> for Gaussian grids. @@ -191,175 +191,175 @@ end subroutine init_grib2 !> !> @author Mark Iredell, George Gayno, Kyle Gerheiser !> @date July 2021 - subroutine gdswzd_gaussian(self, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + subroutine gdswzd_gaussian(self,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) implicit none ! - class(ip_gaussian_grid), intent(in) :: self - integer, intent(in) :: iopt, npts - integer, intent(out) :: nret + class(ip_gaussian_grid),intent(in) :: self + integer,intent(in) :: iopt,npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(npts), rlat(npts) - real, intent(inout) :: xpts(npts), ypts(npts) - real, optional, intent(out) :: crot(npts), srot(npts) - real, optional, intent(out) :: xlon(npts), xlat(npts) - real, optional, intent(out) :: ylon(npts), ylat(npts), area(npts) + real,intent(in) :: fill + real,intent(inout) :: rlon(npts),rlat(npts) + real,intent(inout) :: xpts(npts),ypts(npts) + real,optional,intent(out) :: crot(npts),srot(npts) + real,optional,intent(out) :: xlon(npts),xlat(npts) + real,optional,intent(out) :: ylon(npts),ylat(npts),area(npts) ! - integer :: jscan, im, jm - integer :: j, ja, jg + integer :: jscan,im,jm + integer :: j,ja,jg integer :: n ! - logical :: lrot, lmap, larea + logical :: lrot,lmap,larea ! - real, allocatable :: alat(:), alat_jscan(:) - real, allocatable :: alat_temp(:), blat_temp(:) - real :: hi, rlata, rlatb, rlat1, rlon1, rlon2 - real :: xmax, xmin, ymax, ymin, yptsa, yptsb + real,allocatable :: alat(:),alat_jscan(:) + real,allocatable :: alat_temp(:),blat_temp(:) + real :: hi,rlata,rlatb,rlat1,rlon1,rlon2 + real :: xmax,xmin,ymax,ymin,yptsa,yptsb real :: wb - if (present(crot)) crot = fill - if (present(srot)) srot = fill - if (present(xlon)) xlon = fill - if (present(xlat)) xlat = fill - if (present(ylon)) ylon = fill - if (present(ylat)) ylat = fill - if (present(area)) area = fill + if(present(crot)) crot=fill + if(present(srot)) srot=fill + if(present(xlon)) xlon=fill + if(present(xlat)) xlat=fill + if(present(ylon)) ylon=fill + if(present(ylat)) ylat=fill + if(present(area)) area=fill - if (present(crot) .and. present(srot)) then - lrot = .true. + if(present(crot).and.present(srot)) then + lrot=.true. else - lrot = .false. - end if - if (present(xlon) .and. present(xlat) .and. present(ylon) .and. present(ylat)) then - lmap = .true. + lrot=.false. + endif + if(present(xlon).and.present(xlat).and.present(ylon).and.present(ylat)) then + lmap=.true. else - lmap = .false. - end if - if (present(area)) then - larea = .true. + lmap=.false. + endif + if(present(area)) then + larea=.true. else - larea = .false. - end if + larea=.false. + endif - im = self%im - jm = self%jm + im=self%im + jm=self%jm - rlat1 = self%rlat1 - rlon1 = self%rlon1 - rlon2 = self%rlon2 + rlat1=self%rlat1 + rlon1=self%rlon1 + rlon2=self%rlon2 - jg = self%jg - jscan = self%jscan - hi = self%hi + jg=self%jg + jscan=self%jscan + hi=self%hi - jh = self%jh - dlon = self%dlon - rerth = self%rerth + jh=self%jh + dlon=self%dlon + rerth=self%rerth - allocate (alat_temp(jg)) - allocate (blat_temp(jg)) - call splat(4, jg, alat_temp, blat_temp) - allocate (alat(0:jg+1)) - allocate (blat(0:jg+1)) + allocate(alat_temp(jg)) + allocate(blat_temp(jg)) + call splat(4,jg,alat_temp,blat_temp) + allocate(alat(0:jg+1)) + allocate(blat(0:jg+1)) !$omp parallel do private(ja) schedule(static) - do ja = 1, jg - alat(ja) = real(dpr*asin(alat_temp(ja))) - blat(ja) = blat_temp(ja) - end do + do ja=1,jg + alat(ja)=real(dpr*asin(alat_temp(ja))) + blat(ja)=blat_temp(ja) + enddo !$omp end parallel do - deallocate (alat_temp, blat_temp) - alat(0) = 180.-alat(1) - alat(jg+1) = -alat(0) - blat(0) = -blat(1) - blat(jg+1) = blat(0) - j1 = 1 - do while (j1 .lt. jg .and. rlat1 .lt. (alat(j1)+alat(j1+1))/2) - j1 = j1+1 - end do - if (lmap) then - allocate (alat_jscan(jg)) - do ja = 1, jg - alat_jscan(j1+jh*(ja-1)) = alat(ja) - end do - allocate (ylat_row(0:jg+1)) - do ja = 2, (jg-1) - ylat_row(ja) = 2.0/(alat_jscan(ja+1)-alat_jscan(ja-1)) - end do - ylat_row(1) = 1.0/(alat_jscan(2)-alat_jscan(1)) - ylat_row(0) = ylat_row(1) - ylat_row(jg) = 1.0/(alat_jscan(jg)-alat_jscan(jg-1)) - ylat_row(jg+1) = ylat_row(jg) - deallocate (alat_jscan) - end if - xmin = 0 - xmax = im+1 - if (im .eq. nint(360/abs(dlon))) xmax = im+2 - ymin = 0.5 - ymax = jm+0.5 - nret = 0 + deallocate(alat_temp,blat_temp) + alat(0)=180.-alat(1) + alat(jg+1)=-alat(0) + blat(0)=-blat(1) + blat(jg+1)=blat(0) + j1=1 + do while(j1.lt.jg.and.rlat1.lt.(alat(j1)+alat(j1+1))/2) + j1=j1+1 + enddo + if(lmap) then + allocate(alat_jscan(jg)) + do ja=1,jg + alat_jscan(j1+jh*(ja-1))=alat(ja) + enddo + allocate(ylat_row(0:jg+1)) + do ja=2,(jg-1) + ylat_row(ja)=2.0/(alat_jscan(ja+1)-alat_jscan(ja-1)) + enddo + ylat_row(1)=1.0/(alat_jscan(2)-alat_jscan(1)) + ylat_row(0)=ylat_row(1) + ylat_row(jg)=1.0/(alat_jscan(jg)-alat_jscan(jg-1)) + ylat_row(jg+1)=ylat_row(jg) + deallocate(alat_jscan) + endif + xmin=0 + xmax=im+1 + if(im.eq.nint(360/abs(dlon))) xmax=im+2 + ymin=0.5 + ymax=jm+0.5 + nret=0 ! TRANSLATE GRID COORDINATES TO EARTH COORDINATES - if (iopt .eq. 0 .or. iopt .eq. 1) then - !$omp parallel do private(n, j, wb, rlata, rlatb) reduction(+:nret) schedule(static) - do n = 1, npts - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - rlon(n) = mod(rlon1+dlon*(xpts(n)-1)+3600, 360.) - j = int(ypts(n)) - wb = ypts(n)-j - rlata = alat(j1+jh*(j-1)) - rlatb = alat(j1+jh*j) - rlat(n) = rlata+wb*(rlatb-rlata) - nret = nret+1 - if (lrot) call gaussian_vect_rot(crot(n), srot(n)) - if (lmap) call gaussian_map_jacob(ypts(n), & - xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call gaussian_grid_area(ypts(n), area(n)) + if(iopt.eq.0.or.iopt.eq.1) then + !$omp parallel do private(n,j,wb,rlata,rlatb) reduction(+:nret) schedule(static) + do n=1,npts + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + rlon(n)=mod(rlon1+dlon*(xpts(n)-1)+3600,360.) + j=int(ypts(n)) + wb=ypts(n)-j + rlata=alat(j1+jh*(j-1)) + rlatb=alat(j1+jh*j) + rlat(n)=rlata+wb*(rlatb-rlata) + nret=nret+1 + if(lrot) call gaussian_vect_rot(crot(n),srot(n)) + if(lmap) call gaussian_map_jacob(ypts(n), & + xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call gaussian_grid_area(ypts(n),area(n)) else - rlon(n) = fill - rlat(n) = fill - end if - end do + rlon(n)=fill + rlat(n)=fill + endif + enddo !$omp end parallel do ! TRANSLATE EARTH COORDINATES TO GRID COORDINATES - elseif (iopt .eq. -1) then - !$omp parallel do private(n, ja, yptsa, yptsb, wb) reduction(+:nret) schedule(static) - do n = 1, npts - xpts(n) = fill - ypts(n) = fill - if (abs(rlon(n)) .le. 360 .and. abs(rlat(n)) .le. 90) then - xpts(n) = 1+hi*mod(hi*(rlon(n)-rlon1)+3600, 360.)/dlon - ja = min(int((jg+1)/180.*(90-rlat(n))), jg) - if (rlat(n) .gt. alat(ja)) ja = max(ja-2, 0) - if (rlat(n) .lt. alat(ja+1)) ja = min(ja+2, jg) - if (rlat(n) .gt. alat(ja)) ja = ja-1 - if (rlat(n) .lt. alat(ja+1)) ja = ja+1 - yptsa = 1+jh*(ja-j1) - yptsb = 1+jh*(ja+1-j1) - wb = (alat(ja)-rlat(n))/(alat(ja)-alat(ja+1)) - ypts(n) = yptsa+wb*(yptsb-yptsa) - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - nret = nret+1 - if (lrot) call gaussian_vect_rot(crot(n), srot(n)) - if (lmap) call gaussian_map_jacob(ypts(n), & - xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call gaussian_grid_area(ypts(n), area(n)) + elseif(iopt.eq.-1) then + !$omp parallel do private(n,ja,yptsa,yptsb,wb) reduction(+:nret) schedule(static) + do n=1,npts + xpts(n)=fill + ypts(n)=fill + if(abs(rlon(n)).le.360.and.abs(rlat(n)).le.90) then + xpts(n)=1+hi*mod(hi*(rlon(n)-rlon1)+3600,360.)/dlon + ja=min(int((jg+1)/180.*(90-rlat(n))),jg) + if(rlat(n).gt.alat(ja)) ja=max(ja-2,0) + if(rlat(n).lt.alat(ja+1)) ja=min(ja+2,jg) + if(rlat(n).gt.alat(ja)) ja=ja-1 + if(rlat(n).lt.alat(ja+1)) ja=ja+1 + yptsa=1+jh*(ja-j1) + yptsb=1+jh*(ja+1-j1) + wb=(alat(ja)-rlat(n))/(alat(ja)-alat(ja+1)) + ypts(n)=yptsa+wb*(yptsb-yptsa) + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + nret=nret+1 + if(lrot) call gaussian_vect_rot(crot(n),srot(n)) + if(lmap) call gaussian_map_jacob(ypts(n), & + xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call gaussian_grid_area(ypts(n),area(n)) else - xpts(n) = fill - ypts(n) = fill - end if - end if - end do + xpts(n)=fill + ypts(n)=fill + endif + endif + enddo !$omp end parallel do - end if - deallocate (alat, blat) - if (allocated(ylat_row)) deallocate (ylat_row) + endif + deallocate(alat,blat) + if(allocated(ylat_row)) deallocate(ylat_row) - end subroutine gdswzd_gaussian + endsubroutine gdswzd_gaussian !> Computes the vector rotation sines and cosines for a gaussian !> cylindrical grid. @@ -373,15 +373,15 @@ end subroutine gdswzd_gaussian !> !> @author George Gayno !> @date July 2021 - subroutine gaussian_vect_rot(crot, srot) + subroutine gaussian_vect_rot(crot,srot) implicit none - real, intent(out) :: crot, srot + real,intent(out) :: crot,srot - crot = 1.0 - srot = 0.0 + crot=1.0 + srot=0.0 - end subroutine gaussian_vect_rot + endsubroutine gaussian_vect_rot !> Computes the map jacobians for a gaussian cylindrical grid. !> @@ -393,18 +393,18 @@ end subroutine gaussian_vect_rot !> !> @author George Gayno !> @date July 2021 - subroutine gaussian_map_jacob(ypts, xlon, xlat, ylon, ylat) + subroutine gaussian_map_jacob(ypts,xlon,xlat,ylon,ylat) implicit none - real, intent(in) :: ypts - real, intent(out) :: xlon, xlat, ylon, ylat + real,intent(in) :: ypts + real,intent(out) :: xlon,xlat,ylon,ylat - xlon = 1/dlon - xlat = 0. - ylon = 0. - ylat = ylat_row(nint(ypts)) + xlon=1/dlon + xlat=0. + ylon=0. + ylat=ylat_row(nint(ypts)) - end subroutine gaussian_map_jacob + endsubroutine gaussian_map_jacob !> Computes the grid box area for a gaussian cylindrical grid. !> @@ -413,23 +413,23 @@ end subroutine gaussian_map_jacob !> !> @author Mark Iredell, George Gayno !> @date July 2021 - subroutine gaussian_grid_area(ypts, area) + subroutine gaussian_grid_area(ypts,area) implicit none - real, intent(in) :: ypts - real, intent(out) :: area + real,intent(in) :: ypts + real,intent(out) :: area integer :: j - real :: wb, wlat, wlata, wlatb + real :: wb,wlat,wlata,wlatb - j = int(ypts) - wb = ypts-j - wlata = blat(j1+jh*(j-1)) - wlatb = blat(j1+jh*j) - wlat = wlata+wb*(wlatb-wlata) - area = real(rerth**2*wlat*dlon/dpr) + j=int(ypts) + wb=ypts-j + wlata=blat(j1+jh*(j-1)) + wlatb=blat(j1+jh*j) + wlat=wlata+wb*(wlatb-wlata) + area=real(rerth**2*wlat*dlon/dpr) - end subroutine gaussian_grid_area -end module ip_gaussian_grid_mod + endsubroutine gaussian_grid_area +endmodule ip_gaussian_grid_mod diff --git a/src/ip_grid_descriptor_mod.F90 b/src/ip_grid_descriptor_mod.F90 index 1b67ca6e..4362c9e5 100644 --- a/src/ip_grid_descriptor_mod.F90 +++ b/src/ip_grid_descriptor_mod.F90 @@ -18,49 +18,49 @@ module ip_grid_descriptor_mod private public :: ip_grid_descriptor - public :: grib1_descriptor, grib2_descriptor - public :: init_descriptor, init_grib1_descriptor, init_grib2_descriptor + public :: grib1_descriptor,grib2_descriptor + public :: init_descriptor,init_grib1_descriptor,init_grib2_descriptor public :: operator(==) !> Abstract descriptor object which represents a grib1 or grib2 descriptor. !! @date July 2021 - type, abstract :: ip_grid_descriptor + type,abstract :: ip_grid_descriptor integer :: grid_num !< Integer representing the grid type (see *_GRID_ID_GRIB1/2 in ip_grid_mod). contains !> Test whether two grid descriptors are the same. @return N/A procedure :: is_same_grid - end type ip_grid_descriptor + endtype ip_grid_descriptor !> Descriptor representing a grib1 grib descriptor section (GDS) !> with an integer array !! @date July 2021 - type, extends(ip_grid_descriptor) :: grib1_descriptor + type,extends(ip_grid_descriptor) :: grib1_descriptor integer :: gds(200) !< Grib-1 grib descriptor section (GDS) contains !> Test whether two grid descriptors are the same. @return N/A procedure :: is_same_grid_grib1 - end type grib1_descriptor + endtype grib1_descriptor !> Grib-2 descriptor containing a grib2 GDT represented by an integer array !! @date July 2021 - type, extends(ip_grid_descriptor) :: grib2_descriptor + type,extends(ip_grid_descriptor) :: grib2_descriptor integer :: gdt_num !< Grid number which represents grid type. integer :: gdt_len !< Length of the template. - integer, allocatable :: gdt_tmpl(:) !< Grib-2 grid definition template. + integer,allocatable :: gdt_tmpl(:) !< Grib-2 grid definition template. contains !> Test whether two grid descriptors are the same. @return N/A procedure :: is_same_grid_grib2 - end type grib2_descriptor + endtype grib2_descriptor interface operator(==) module procedure is_same_grid - end interface operator(==) + endinterface operator(==) interface init_descriptor module procedure init_grib1_descriptor module procedure init_grib2_descriptor - end interface init_descriptor + endinterface init_descriptor contains @@ -73,13 +73,13 @@ module ip_grid_descriptor_mod !! @date July 2021 function init_grib1_descriptor(gds) result(desc) type(grib1_descriptor) :: desc - integer, intent(in) :: gds(:) - desc%gds = gds - desc%grid_num = gds(1) + integer,intent(in) :: gds(:) + desc%gds=gds + desc%grid_num=gds(1) !call desc%decode_template() - end function init_grib1_descriptor + endfunction init_grib1_descriptor !> Initialize grib-2 descriptor from integer grid definition template (GDT). !! @param[in] gdt_num Grib-2 grid number. @@ -90,19 +90,19 @@ end function init_grib1_descriptor !! !! @author Kyle Gerheiser !! @date July 2021 - function init_grib2_descriptor(gdt_num, gdt_len, gdt_tmpl) result(desc) + function init_grib2_descriptor(gdt_num,gdt_len,gdt_tmpl) result(desc) type(grib2_descriptor) :: desc - integer, intent(in) :: gdt_num, gdt_len, gdt_tmpl(:) - desc%grid_num = gdt_num + integer,intent(in) :: gdt_num,gdt_len,gdt_tmpl(:) + desc%grid_num=gdt_num - desc%gdt_num = gdt_num - desc%gdt_len = gdt_len - allocate (desc%gdt_tmpl(gdt_len)) - desc%gdt_tmpl = gdt_tmpl + desc%gdt_num=gdt_num + desc%gdt_len=gdt_len + allocate(desc%gdt_tmpl(gdt_len)) + desc%gdt_tmpl=gdt_tmpl !call desc%decode_template() - end function init_grib2_descriptor + endfunction init_grib2_descriptor !> Test whether two grid descriptors are the same. !! @param[in] grid1 An ip_grid_descriptor. @@ -112,27 +112,27 @@ end function init_grib2_descriptor !! !! @author Kyle Gerheiser !! @date July 2021 - logical function is_same_grid(grid1, grid2) - class(ip_grid_descriptor), intent(in) :: grid1, grid2 - - select type (grid1) - type is (grib1_descriptor) - select type (grid2) - type is (grib1_descriptor) - is_same_grid = grid1%is_same_grid_grib1(grid2) + logical function is_same_grid(grid1,grid2) + class(ip_grid_descriptor),intent(in) :: grid1,grid2 + + select type(grid1) + type is(grib1_descriptor) + select type(grid2) + type is(grib1_descriptor) + is_same_grid=grid1%is_same_grid_grib1(grid2) class default - is_same_grid = .false. - end select - type is (grib2_descriptor) - select type (grid2) - type is (grib2_descriptor) - is_same_grid = grid1%is_same_grid_grib2(grid2) + is_same_grid=.false. + endselect + type is(grib2_descriptor) + select type(grid2) + type is(grib2_descriptor) + is_same_grid=grid1%is_same_grid_grib2(grid2) class default - is_same_grid = .false. - end select - end select + is_same_grid=.false. + endselect + endselect - end function is_same_grid + endfunction is_same_grid !> Test whether two grib1_descriptors are the same. !! @param[in] self The grib1_descriptor which this routine was called on. @@ -142,16 +142,16 @@ end function is_same_grid !! !! @author Kyle Gerheiser !! @date July 2021 - logical function is_same_grid_grib1(self, grid_desc) result(same_grid) - class(grib1_descriptor), intent(in) :: self, grid_desc + logical function is_same_grid_grib1(self,grid_desc) result(same_grid) + class(grib1_descriptor),intent(in) :: self,grid_desc - if (all(self%gds .eq. grid_desc%gds)) then - same_grid = .true. + if(all(self%gds.eq.grid_desc%gds)) then + same_grid=.true. else - same_grid = .false. - end if + same_grid=.false. + endif - end function is_same_grid_grib1 + endfunction is_same_grid_grib1 !> Test whether two grib2_descriptors are the same. !! @param[in] self The grib2_descriptor which this routine was called on. @@ -161,19 +161,19 @@ end function is_same_grid_grib1 !! !! @author Kyle Gerheiser !! @date July 2021 - logical function is_same_grid_grib2(self, grid_desc) result(same_grid) - class(grib2_descriptor), intent(in) :: self, grid_desc + logical function is_same_grid_grib2(self,grid_desc) result(same_grid) + class(grib2_descriptor),intent(in) :: self,grid_desc - same_grid = .false. - if (self%grid_num .eq. grid_desc%grid_num) then - if (self%gdt_len .eq. grid_desc%gdt_len) then - if (all(self%gdt_tmpl .eq. grid_desc%gdt_tmpl)) then - same_grid = .true. - end if - end if - end if + same_grid=.false. + if(self%grid_num.eq.grid_desc%grid_num) then + if(self%gdt_len.eq.grid_desc%gdt_len) then + if(all(self%gdt_tmpl.eq.grid_desc%gdt_tmpl)) then + same_grid=.true. + endif + endif + endif - end function is_same_grid_grib2 + endfunction is_same_grid_grib2 ! subroutine decode_template_grib1(self) ! type(grib1_descriptor), intent(inout) :: self @@ -525,4 +525,4 @@ end function is_same_grid_grib2 ! end select ! end subroutine earth_radius -end module ip_grid_descriptor_mod +endmodule ip_grid_descriptor_mod diff --git a/src/ip_grid_factory_mod.F90 b/src/ip_grid_factory_mod.F90 index 050ec5f5..d72bd0ed 100644 --- a/src/ip_grid_factory_mod.F90 +++ b/src/ip_grid_factory_mod.F90 @@ -19,7 +19,7 @@ module ip_grid_factory_mod interface init_grid module procedure init_grid_generic - end interface init_grid + endinterface init_grid contains @@ -30,17 +30,17 @@ module ip_grid_factory_mod !! !! @author Kyle Gerheiser !! @date July 2021 - subroutine init_grid_generic(grid, grid_desc) - class(ip_grid_descriptor), intent(in) :: grid_desc - class(ip_grid), allocatable, intent(out) :: grid + subroutine init_grid_generic(grid,grid_desc) + class(ip_grid_descriptor),intent(in) :: grid_desc + class(ip_grid),allocatable,intent(out) :: grid - select type (grid_desc) - type is (grib1_descriptor) - call init_grid_grib1(grid, grid_desc) - type is (grib2_descriptor) - call init_grid_grib2(grid, grid_desc) - end select - end subroutine init_grid_generic + select type(grid_desc) + type is(grib1_descriptor) + call init_grid_grib1(grid,grid_desc) + type is(grib2_descriptor) + call init_grid_grib2(grid,grid_desc) + endselect + endsubroutine init_grid_generic !> Initializes a polymorphic ip_grid from a grib1_descriptor. !! The concrete grid type is chosen based on the grid number in the descriptor. @@ -50,32 +50,32 @@ end subroutine init_grid_generic !! !! @author Kyle Gerheiser !! @date July 2021 - subroutine init_grid_grib1(grid, g1_desc) - type(grib1_descriptor), intent(in) :: g1_desc - class(ip_grid), allocatable, intent(out) :: grid + subroutine init_grid_grib1(grid,g1_desc) + type(grib1_descriptor),intent(in) :: g1_desc + class(ip_grid),allocatable,intent(out) :: grid - select case (g1_desc%grid_num) - case (:-1) - allocate (ip_station_points_grid::grid) - case (equid_cylind_grid_id_grib1) - allocate (ip_equid_cylind_grid::grid) - case (mercator_grid_id_grib1) - allocate (ip_mercator_grid::grid) - case (lambert_conf_grid_id_grib1) - allocate (ip_lambert_conf_grid::grid) - case (gaussian_grid_id_grib1) - allocate (ip_gaussian_grid::grid) - case (polar_stereo_grid_id_grib1) - allocate (ip_polar_stereo_grid::grid) - case (rot_equid_cylind_e_grid_id_grib1) - allocate (ip_rot_equid_cylind_egrid::grid) - case (rot_equid_cylind_b_grid_id_grib1) - allocate (ip_rot_equid_cylind_grid::grid) - end select + select case(g1_desc%grid_num) + case(:-1) + allocate(ip_station_points_grid::grid) + case(equid_cylind_grid_id_grib1) + allocate(ip_equid_cylind_grid::grid) + case(mercator_grid_id_grib1) + allocate(ip_mercator_grid::grid) + case(lambert_conf_grid_id_grib1) + allocate(ip_lambert_conf_grid::grid) + case(gaussian_grid_id_grib1) + allocate(ip_gaussian_grid::grid) + case(polar_stereo_grid_id_grib1) + allocate(ip_polar_stereo_grid::grid) + case(rot_equid_cylind_e_grid_id_grib1) + allocate(ip_rot_equid_cylind_egrid::grid) + case(rot_equid_cylind_b_grid_id_grib1) + allocate(ip_rot_equid_cylind_grid::grid) + endselect call grid%init(g1_desc) - allocate (grid%descriptor, source=g1_desc) - end subroutine init_grid_grib1 + allocate(grid%descriptor,source=g1_desc) + endsubroutine init_grid_grib1 !> Initializes a polymorphic ip_grid from a grib2_descriptor. !! The concrete grid type is chosen based on the grid number in the descriptor. @@ -85,44 +85,44 @@ end subroutine init_grid_grib1 !! !! @author Kyle Gerheiser !! @date July 2021 - subroutine init_grid_grib2(grid, g2_desc) - type(grib2_descriptor), intent(in) :: g2_desc - class(ip_grid), allocatable, intent(out) :: grid + subroutine init_grid_grib2(grid,g2_desc) + type(grib2_descriptor),intent(in) :: g2_desc + class(ip_grid),allocatable,intent(out) :: grid - integer :: i_offset_odd, i_offset_even + integer :: i_offset_odd,i_offset_even - select case (g2_desc%grid_num) - case (:-1) - allocate (ip_station_points_grid::grid) - case (equid_cylind_grid_id_grib2) - allocate (ip_equid_cylind_grid::grid) - case (rot_equid_cylind_grid_id_grib2) - i_offset_odd = mod(g2_desc%gdt_tmpl(19)/8, 2) - i_offset_even = mod(g2_desc%gdt_tmpl(19)/4, 2) - if (i_offset_odd .ne. i_offset_even) then - allocate (ip_rot_equid_cylind_egrid::grid) + select case(g2_desc%grid_num) + case(:-1) + allocate(ip_station_points_grid::grid) + case(equid_cylind_grid_id_grib2) + allocate(ip_equid_cylind_grid::grid) + case(rot_equid_cylind_grid_id_grib2) + i_offset_odd=mod(g2_desc%gdt_tmpl(19)/8,2) + i_offset_even=mod(g2_desc%gdt_tmpl(19)/4,2) + if(i_offset_odd.ne.i_offset_even) then + allocate(ip_rot_equid_cylind_egrid::grid) else - allocate (ip_rot_equid_cylind_grid::grid) - end if - case (mercator_grid_id_grib2) - allocate (ip_mercator_grid::grid) - case (polar_stereo_grid_id_grib2) - allocate (ip_polar_stereo_grid::grid) - case (lambert_conf_grid_id_grib2) - allocate (ip_lambert_conf_grid::grid) - case (gaussian_grid_id_grib2) - allocate (ip_gaussian_grid::grid) - case (rot_equid_cylind_e_grid_id_grib2) - allocate (ip_rot_equid_cylind_egrid::grid) - case (rot_equid_cylind_b_grid_id_grib2) - allocate (ip_rot_equid_cylind_grid::grid) + allocate(ip_rot_equid_cylind_grid::grid) + endif + case(mercator_grid_id_grib2) + allocate(ip_mercator_grid::grid) + case(polar_stereo_grid_id_grib2) + allocate(ip_polar_stereo_grid::grid) + case(lambert_conf_grid_id_grib2) + allocate(ip_lambert_conf_grid::grid) + case(gaussian_grid_id_grib2) + allocate(ip_gaussian_grid::grid) + case(rot_equid_cylind_e_grid_id_grib2) + allocate(ip_rot_equid_cylind_egrid::grid) + case(rot_equid_cylind_b_grid_id_grib2) + allocate(ip_rot_equid_cylind_grid::grid) case default - print *, "gdt_num: ", g2_desc%gdt_num, " not recognized" + print*,"gdt_num: ",g2_desc%gdt_num," not recognized" error stop - end select + endselect call grid%init(g2_desc) - allocate (grid%descriptor, source=g2_desc) - end subroutine init_grid_grib2 + allocate(grid%descriptor,source=g2_desc) + endsubroutine init_grid_grib2 -end module ip_grid_factory_mod +endmodule ip_grid_factory_mod diff --git a/src/ip_grid_mod.F90 b/src/ip_grid_mod.F90 index aa7c61bd..cccc4cd8 100644 --- a/src/ip_grid_mod.F90 +++ b/src/ip_grid_mod.F90 @@ -11,22 +11,22 @@ module ip_grid_mod use ip_grid_descriptor_mod implicit none - integer, public, parameter :: equid_cylind_grid_id_grib1 = 0 !< Integer grid number for equidistant cylindrical grid in grib1 - integer, public, parameter :: mercator_grid_id_grib1 = 1 !< Integer grid number for Mercator grid in grib1 - integer, public, parameter :: lambert_conf_grid_id_grib1 = 3 !< Integer grid number for Lambert Conformal grid in grib1 - integer, public, parameter :: gaussian_grid_id_grib1 = 4 !< Integer grid number for Gaussian grid in grib1 - integer, public, parameter :: polar_stereo_grid_id_grib1 = 5 !< Integer grid number for polar stereo grid in grib1 - integer, public, parameter :: rot_equid_cylind_e_grid_id_grib1 = 203 !< Integer grid number for rotated equidistant cylindrical E-stagger grid - integer, public, parameter :: rot_equid_cylind_b_grid_id_grib1 = 205 !< Integer grid number for rotated equidistant cylindrical B-stagger grid - - integer, public, parameter :: equid_cylind_grid_id_grib2 = 0 !< Integer grid number for equidistant cylindrical grid in grib2 - integer, public, parameter :: rot_equid_cylind_grid_id_grib2 = 1 !< Integer grid number for rotated equidistant cylindrical grid in grib2 - integer, public, parameter :: mercator_grid_id_grib2 = 10 !< Integer grid number for Mercator grid in grib2 - integer, public, parameter :: polar_stereo_grid_id_grib2 = 20 !< Integer grid number for polar stereo grid in grib2 - integer, public, parameter :: lambert_conf_grid_id_grib2 = 30 !< Integer grid number for Lambert conformal grid in grib2 - integer, public, parameter :: gaussian_grid_id_grib2 = 40 !< Integer grid number for Gaussian grid in grib2 - integer, public, parameter :: rot_equid_cylind_e_grid_id_grib2 = 32768 !< Integer grid number for rotated equidistant cylindrical E-stagger grid (grib2) - integer, public, parameter :: rot_equid_cylind_b_grid_id_grib2 = 32769 !< Integer grid number for rotated equidistant cylindrical B-stagger grid (grib2) + integer,public,parameter :: equid_cylind_grid_id_grib1=0 !< Integer grid number for equidistant cylindrical grid in grib1 + integer,public,parameter :: mercator_grid_id_grib1=1 !< Integer grid number for Mercator grid in grib1 + integer,public,parameter :: lambert_conf_grid_id_grib1=3 !< Integer grid number for Lambert Conformal grid in grib1 + integer,public,parameter :: gaussian_grid_id_grib1=4 !< Integer grid number for Gaussian grid in grib1 + integer,public,parameter :: polar_stereo_grid_id_grib1=5 !< Integer grid number for polar stereo grid in grib1 + integer,public,parameter :: rot_equid_cylind_e_grid_id_grib1=203 !< Integer grid number for rotated equidistant cylindrical E-stagger grid + integer,public,parameter :: rot_equid_cylind_b_grid_id_grib1=205 !< Integer grid number for rotated equidistant cylindrical B-stagger grid + + integer,public,parameter :: equid_cylind_grid_id_grib2=0 !< Integer grid number for equidistant cylindrical grid in grib2 + integer,public,parameter :: rot_equid_cylind_grid_id_grib2=1 !< Integer grid number for rotated equidistant cylindrical grid in grib2 + integer,public,parameter :: mercator_grid_id_grib2=10 !< Integer grid number for Mercator grid in grib2 + integer,public,parameter :: polar_stereo_grid_id_grib2=20 !< Integer grid number for polar stereo grid in grib2 + integer,public,parameter :: lambert_conf_grid_id_grib2=30 !< Integer grid number for Lambert conformal grid in grib2 + integer,public,parameter :: gaussian_grid_id_grib2=40 !< Integer grid number for Gaussian grid in grib2 + integer,public,parameter :: rot_equid_cylind_e_grid_id_grib2=32768 !< Integer grid number for rotated equidistant cylindrical E-stagger grid (grib2) + integer,public,parameter :: rot_equid_cylind_b_grid_id_grib2=32769 !< Integer grid number for rotated equidistant cylindrical B-stagger grid (grib2) private public :: ip_grid @@ -51,8 +51,8 @@ module ip_grid_mod !! NCEPLIBS-ip can be found here: https://doi.org/10.3133/pp1395. !! !! @author Kyle Gerheiser @date July 2021 - type, abstract :: ip_grid - class(ip_grid_descriptor), allocatable :: descriptor !< Descriptor. + type,abstract :: ip_grid + class(ip_grid_descriptor),allocatable :: descriptor !< Descriptor. integer :: im !< Number of x points integer :: jm !< Number of y points @@ -74,17 +74,17 @@ module ip_grid_mod real :: eccen_squared !< Eccentricity of the Earth squared (e^2). contains !> Initializer for grib1 input descriptor. @return N/A - procedure(init_grib1_interface), deferred :: init_grib1 + procedure(init_grib1_interface),deferred :: init_grib1 !> Initializer for grib2 input descriptor. @return N/A - procedure(init_grib2_interface), deferred :: init_grib2 + procedure(init_grib2_interface),deferred :: init_grib2 !> Coordinate transformations for the grid. @return N/A - procedure(gdswzd_interface), deferred :: gdswzd + procedure(gdswzd_interface),deferred :: gdswzd !> Field position for a given grid point. @return Integer !> position in grib field to locate grid point. procedure :: field_pos !> Init subprogram. @return N/A - generic :: init => init_grib1, init_grib2 - end type ip_grid + generic :: init=>init_grib1,init_grib2 + endtype ip_grid abstract interface @@ -118,20 +118,20 @@ module ip_grid_mod !> (proportional to the square of the map factor) !> !> @author Kyle Gerheiser @date July 2021 - subroutine gdswzd_interface(self, iopt, npts, fill, xpts, ypts, rlon, rlat, nret, crot, srot, & - xlon, xlat, ylon, ylat, area) + subroutine gdswzd_interface(self,iopt,npts,fill,xpts,ypts,rlon,rlat,nret,crot,srot, & + xlon,xlat,ylon,ylat,area) import - class(ip_grid), intent(in) :: self - integer, intent(in) :: iopt, npts - integer, intent(out) :: nret + class(ip_grid),intent(in) :: self + integer,intent(in) :: iopt,npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(npts), rlat(npts) - real, intent(inout) :: xpts(npts), ypts(npts) - real, optional, intent(out) :: crot(npts), srot(npts) - real, optional, intent(out) :: xlon(npts), xlat(npts) - real, optional, intent(out) :: ylon(npts), ylat(npts), area(npts) - end subroutine gdswzd_interface + real,intent(in) :: fill + real,intent(inout) :: rlon(npts),rlat(npts) + real,intent(inout) :: xpts(npts),ypts(npts) + real,optional,intent(out) :: crot(npts),srot(npts) + real,optional,intent(out) :: xlon(npts),xlat(npts) + real,optional,intent(out) :: ylon(npts),ylat(npts),area(npts) + endsubroutine gdswzd_interface !> @fn ip_grid_mod::init_grib1_interface::init_grib1_interface(self, g1_desc) !> Init GRIB1 interface. @@ -141,11 +141,11 @@ end subroutine gdswzd_interface !> !> @author Kyle Gerheiser !> @date July 2021 - subroutine init_grib1_interface(self, g1_desc) + subroutine init_grib1_interface(self,g1_desc) import - class(ip_grid), intent(inout) :: self - type(grib1_descriptor), intent(in) :: g1_desc - end subroutine init_grib1_interface + class(ip_grid),intent(inout) :: self + type(grib1_descriptor),intent(in) :: g1_desc + endsubroutine init_grib1_interface !> @fn ip_grid_mod::init_grib2_interface::init_grib2_interface(self, g2_desc) !> Init GRIB2 interface. @@ -155,19 +155,19 @@ end subroutine init_grib1_interface !> !> @author Kyle Gerheiser !> @date July 2021 - subroutine init_grib2_interface(self, g2_desc) + subroutine init_grib2_interface(self,g2_desc) import - class(ip_grid), intent(inout) :: self - type(grib2_descriptor), intent(in) :: g2_desc - end subroutine init_grib2_interface + class(ip_grid),intent(inout) :: self + type(grib2_descriptor),intent(in) :: g2_desc + endsubroutine init_grib2_interface - end interface + endinterface !> Check equality. !> @author Kyle Gerheiser @date July 2021 interface operator(==) module procedure is_same_grid - end interface operator(==) + endinterface operator(==) contains @@ -180,10 +180,10 @@ end subroutine init_grib2_interface !> !> @author Kyle Gerheiser !> @date July 2021 - logical function is_same_grid(grid1, grid2) - class(ip_grid), intent(in) :: grid1, grid2 - is_same_grid = grid1%descriptor .eq. grid2%descriptor - end function is_same_grid + logical function is_same_grid(grid1,grid2) + class(ip_grid),intent(in) :: grid1,grid2 + is_same_grid=grid1%descriptor.eq.grid2%descriptor + endfunction is_same_grid !> Returns the field position for a given grid point. !> @@ -195,57 +195,57 @@ end function is_same_grid !> !> @author Mark Iredell, George Gayno, Kyle Gerheiser !> @date April 1996 - function field_pos(self, i, j) - class(ip_grid), intent(in) :: self - integer, intent(in) :: i, j + function field_pos(self,i,j) + class(ip_grid),intent(in) :: self + integer,intent(in) :: i,j integer :: field_pos - integer :: ii, jj, im, jm - integer :: iif, jjf, is1, iwrap - integer :: jwrap1, jwrap2, kscan, nscan + integer :: ii,jj,im,jm + integer :: iif,jjf,is1,iwrap + integer :: jwrap1,jwrap2,kscan,nscan ! extract from navigation parameter array - im = self%im - jm = self%jm - iwrap = self%iwrap - jwrap1 = self%jwrap1 - jwrap2 = self%jwrap2 - nscan = self%nscan_field_pos - kscan = self%kscan + im=self%im + jm=self%jm + iwrap=self%iwrap + jwrap1=self%jwrap1 + jwrap2=self%jwrap2 + nscan=self%nscan_field_pos + kscan=self%kscan ! compute wraparounds in x and y if necessary and possible - ii = i - jj = j - if (iwrap .gt. 0) then - ii = mod(i-1+iwrap, iwrap)+1 - if (j .lt. 1 .and. jwrap1 .gt. 0) then - jj = jwrap1-j - ii = mod(ii-1+iwrap/2, iwrap)+1 - elseif (j .gt. jm .and. jwrap2 .gt. 0) then - jj = jwrap2-j - ii = mod(ii-1+iwrap/2, iwrap)+1 - end if - end if + ii=i + jj=j + if(iwrap.gt.0) then + ii=mod(i-1+iwrap,iwrap)+1 + if(j.lt.1.and.jwrap1.gt.0) then + jj=jwrap1-j + ii=mod(ii-1+iwrap/2,iwrap)+1 + elseif(j.gt.jm.and.jwrap2.gt.0) then + jj=jwrap2-j + ii=mod(ii-1+iwrap/2,iwrap)+1 + endif + endif ! compute position for the appropriate scanning mode - field_pos = 0 - if (nscan .eq. 0) then - if (ii .ge. 1 .and. ii .le. im .and. jj .ge. 1 .and. jj .le. jm) field_pos = ii+(jj-1)*im - elseif (nscan .eq. 1) then - if (ii .ge. 1 .and. ii .le. im .and. jj .ge. 1 .and. jj .le. jm) field_pos = jj+(ii-1)*jm - elseif (nscan .eq. 2) then - is1 = (jm+1-kscan)/2 - iif = jj+(ii-is1) - jjf = jj-(ii-is1)+kscan - if (iif .ge. 1 .and. iif .le. 2*im-1 .and. jjf .ge. 1 .and. jjf .le. jm) & - field_pos = (iif+(jjf-1)*(2*im-1)+1-kscan)/2 - elseif (nscan .eq. 3) then - is1 = (jm+1-kscan)/2 - iif = jj+(ii-is1) - jjf = jj-(ii-is1)+kscan - if (iif .ge. 1 .and. iif .le. 2*im-1 .and. jjf .ge. 1 .and. jjf .le. jm) field_pos = (iif+1)/2+(jjf-1)*im - end if - end function field_pos - -end module ip_grid_mod + field_pos=0 + if(nscan.eq.0) then + if(ii.ge.1.and.ii.le.im.and.jj.ge.1.and.jj.le.jm) field_pos=ii+(jj-1)*im + elseif(nscan.eq.1) then + if(ii.ge.1.and.ii.le.im.and.jj.ge.1.and.jj.le.jm) field_pos=jj+(ii-1)*jm + elseif(nscan.eq.2) then + is1=(jm+1-kscan)/2 + iif=jj+(ii-is1) + jjf=jj-(ii-is1)+kscan + if(iif.ge.1.and.iif.le.2*im-1.and.jjf.ge.1.and.jjf.le.jm) & + field_pos=(iif+(jjf-1)*(2*im-1)+1-kscan)/2 + elseif(nscan.eq.3) then + is1=(jm+1-kscan)/2 + iif=jj+(ii-is1) + jjf=jj-(ii-is1)+kscan + if(iif.ge.1.and.iif.le.2*im-1.and.jjf.ge.1.and.jjf.le.jm) field_pos=(iif+1)/2+(jjf-1)*im + endif + endfunction field_pos + +endmodule ip_grid_mod diff --git a/src/ip_grids_mod.F90 b/src/ip_grids_mod.F90 index 037ff453..8ccdcd66 100644 --- a/src/ip_grids_mod.F90 +++ b/src/ip_grids_mod.F90 @@ -15,5 +15,5 @@ module ip_grids_mod use ip_station_points_grid_mod use ip_grid_mod implicit none -end module ip_grids_mod +endmodule ip_grids_mod diff --git a/src/ip_interpolators_mod.F90 b/src/ip_interpolators_mod.F90 index 5b82e535..a76fc5f1 100644 --- a/src/ip_interpolators_mod.F90 +++ b/src/ip_interpolators_mod.F90 @@ -14,19 +14,19 @@ module ip_interpolators_mod implicit none !> @param Constant to choose BILINEAR interpolation method - integer, parameter, public :: bilinear_interp_id = 0 + integer,parameter,public :: bilinear_interp_id=0 !> @param Constant to choose BICUBIC interpolation method - integer, parameter, public :: bicubic_interp_id = 1 + integer,parameter,public :: bicubic_interp_id=1 !> @param Constant to choose NEIGBOR interpolation method - integer, parameter, public :: neighbor_interp_id = 2 + integer,parameter,public :: neighbor_interp_id=2 !> @param Constant to choose BUDGET interpolation method - integer, parameter, public :: budget_interp_id = 3 + integer,parameter,public :: budget_interp_id=3 !> @param Constant to choose SPECTRAL interpolation method - integer, parameter, public :: spectral_interp_id = 4 + integer,parameter,public :: spectral_interp_id=4 !> @param Constant to choose NEIGBOR_BUDGET interpolation method - integer, parameter, public :: neighbor_budget_interp_id = 6 + integer,parameter,public :: neighbor_budget_interp_id=6 contains -end module ip_interpolators_mod +endmodule ip_interpolators_mod diff --git a/src/ip_lambert_conf_grid_mod.F90 b/src/ip_lambert_conf_grid_mod.F90 index 1528ca10..9fd50fd8 100644 --- a/src/ip_lambert_conf_grid_mod.F90 +++ b/src/ip_lambert_conf_grid_mod.F90 @@ -21,7 +21,7 @@ module ip_lambert_conf_grid_mod private public :: ip_lambert_conf_grid - type, extends(ip_grid) :: ip_lambert_conf_grid + type,extends(ip_grid) :: ip_lambert_conf_grid real :: rlat1 !< La1― latitude of first grid point. GRIB2, Section 3.30, octet 39-42. real :: rlon1 !< Lo1― longitude of first grid point. GRIB2, Section 3.30, octet 43-46. real :: rlati1 !< First latitude from the pole at which the secant cone cuts the sphere. GRIB2, Section 3, octets 66-69. @@ -38,8 +38,8 @@ module ip_lambert_conf_grid_mod procedure :: init_grib2 !> Calculates Earth coordinates (iopt = 1) or grid coorindates (iopt = -1) !> for Gaussian grids. @return N/A - procedure :: gdswzd => gdswzd_lambert_conf - end type ip_lambert_conf_grid + procedure :: gdswzd=>gdswzd_lambert_conf + endtype ip_lambert_conf_grid integer :: irot !< vector rotation flag. When "1", vectors are grid relative. When "0", vectors are earth relative. GRIB2, Section 3, octet 55. real :: an !< Cone factor @@ -47,7 +47,7 @@ module ip_lambert_conf_grid_mod real :: dys !< y-direction grid length adjusted for scan model. GRIB2, Section 3, octets 60-63. real :: h !< Hemisphere flag. 1-NH, minus 1-SH. real :: rerth !< Radius of the earth. GRIB2, Section 3, octets 15-30. - real :: tinyreal = tiny(1.0) !< Smallest positive real value (use for equality comparisons) + real :: tinyreal=tiny(1.0) !< Smallest positive real value (use for equality comparisons) contains @@ -57,51 +57,51 @@ module ip_lambert_conf_grid_mod !! @param[in] g1_desc A grib1_descriptor !! !! @author Iredell @date 96-04-10 - subroutine init_grib1(self, g1_desc) - class(ip_lambert_conf_grid), intent(inout) :: self - type(grib1_descriptor), intent(in) :: g1_desc + subroutine init_grib1(self,g1_desc) + class(ip_lambert_conf_grid),intent(inout) :: self + type(grib1_descriptor),intent(in) :: g1_desc - real :: dx, dy, hi, hj - integer :: iproj, iscan, jscan + real :: dx,dy,hi,hj + integer :: iproj,iscan,jscan - associate (kgds => g1_desc%gds) - self%rerth = 6.3712e6 - self%eccen_squared = 0.0 + associate(kgds=>g1_desc%gds) + self%rerth=6.3712e6 + self%eccen_squared=0.0 - self%im = kgds(2) - self%jm = kgds(3) + self%im=kgds(2) + self%jm=kgds(3) - self%rlat1 = kgds(4)*1.e-3 - self%rlon1 = kgds(5)*1.e-3 + self%rlat1=kgds(4)*1.e-3 + self%rlon1=kgds(5)*1.e-3 - self%irot = mod(kgds(6)/8, 2) - self%orient = kgds(7)*1.e-3 + self%irot=mod(kgds(6)/8,2) + self%orient=kgds(7)*1.e-3 - dx = kgds(8) - dy = kgds(9) + dx=kgds(8) + dy=kgds(9) - iproj = mod(kgds(10)/128, 2) - iscan = mod(kgds(11)/128, 2) - jscan = mod(kgds(11)/64, 2) + iproj=mod(kgds(10)/128,2) + iscan=mod(kgds(11)/128,2) + jscan=mod(kgds(11)/64,2) - self%rlati1 = kgds(12)*1.e-3 - self%rlati2 = kgds(13)*1.e-3 - self%h = (-1.)**iproj + self%rlati1=kgds(12)*1.e-3 + self%rlati2=kgds(13)*1.e-3 + self%h=(-1.)**iproj - hi = (-1.)**iscan - hj = (-1.)**(1-jscan) - self%dxs = dx*hi - self%dys = dy*hj + hi=(-1.)**iscan + hj=(-1.)**(1-jscan) + self%dxs=dx*hi + self%dys=dy*hj - self%iwrap = 0 - self%jwrap1 = 0 - self%jwrap2 = 0 - self%nscan = mod(kgds(11)/32, 2) - self%nscan_field_pos = self%nscan - self%kscan = 0 - end associate + self%iwrap=0 + self%jwrap1=0 + self%jwrap2=0 + self%nscan=mod(kgds(11)/32,2) + self%nscan_field_pos=self%nscan + self%kscan=0 + endassociate - end subroutine init_grib1 + endsubroutine init_grib1 !> Initializes a Lambert Conformal grid given a grib2_descriptor object. !! @@ -109,49 +109,49 @@ end subroutine init_grib1 !! @param[in] g2_desc A grib2_descriptor !! !! @author Iredell @date 96-04-10 - subroutine init_grib2(self, g2_desc) - class(ip_lambert_conf_grid), intent(inout) :: self - type(grib2_descriptor), intent(in) :: g2_desc + subroutine init_grib2(self,g2_desc) + class(ip_lambert_conf_grid),intent(inout) :: self + type(grib2_descriptor),intent(in) :: g2_desc - real :: dx, dy, hi, hj - integer :: iproj, iscan, jscan + real :: dx,dy,hi,hj + integer :: iproj,iscan,jscan - associate (igdtmpl => g2_desc%gdt_tmpl, igdtlen => g2_desc%gdt_len) - call earth_radius(igdtmpl, igdtlen, self%rerth, self%eccen_squared) + associate(igdtmpl=>g2_desc%gdt_tmpl,igdtlen=>g2_desc%gdt_len) + call earth_radius(igdtmpl,igdtlen,self%rerth,self%eccen_squared) - self%im = igdtmpl(8) - self%jm = igdtmpl(9) + self%im=igdtmpl(8) + self%jm=igdtmpl(9) - self%rlat1 = float(igdtmpl(10))*1.0e-6 - self%rlon1 = float(igdtmpl(11))*1.0e-6 + self%rlat1=float(igdtmpl(10))*1.0e-6 + self%rlon1=float(igdtmpl(11))*1.0e-6 - self%irot = mod(igdtmpl(12)/8, 2) - self%orient = float(igdtmpl(14))*1.0e-6 + self%irot=mod(igdtmpl(12)/8,2) + self%orient=float(igdtmpl(14))*1.0e-6 - dx = float(igdtmpl(15))*1.0e-3 - dy = float(igdtmpl(16))*1.0e-3 + dx=float(igdtmpl(15))*1.0e-3 + dy=float(igdtmpl(16))*1.0e-3 - iproj = mod(igdtmpl(17)/128, 2) - iscan = mod(igdtmpl(18)/128, 2) - jscan = mod(igdtmpl(18)/64, 2) + iproj=mod(igdtmpl(17)/128,2) + iscan=mod(igdtmpl(18)/128,2) + jscan=mod(igdtmpl(18)/64,2) - self%rlati1 = float(igdtmpl(19))*1.0e-6 - self%rlati2 = float(igdtmpl(20))*1.0e-6 + self%rlati1=float(igdtmpl(19))*1.0e-6 + self%rlati2=float(igdtmpl(20))*1.0e-6 - self%h = (-1.)**iproj - hi = (-1.)**iscan - hj = (-1.)**(1-jscan) - self%dxs = dx*hi - self%dys = dy*hj + self%h=(-1.)**iproj + hi=(-1.)**iscan + hj=(-1.)**(1-jscan) + self%dxs=dx*hi + self%dys=dy*hj - self%nscan = mod(igdtmpl(18)/32, 2) - self%nscan_field_pos = self%nscan - self%iwrap = 0 - self%jwrap1 = 0 - self%jwrap2 = 0 - self%kscan = 0 - end associate - end subroutine init_grib2 + self%nscan=mod(igdtmpl(18)/32,2) + self%nscan_field_pos=self%nscan + self%iwrap=0 + self%jwrap1=0 + self%jwrap2=0 + self%kscan=0 + endassociate + endsubroutine init_grib2 !> GDS wizard for lambert conformal conical. !> @@ -215,158 +215,158 @@ end subroutine init_grib2 !> (proportional to the square of the map factor) !> !> @author Iredell @date 96-04-10 - subroutine gdswzd_lambert_conf(self, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + subroutine gdswzd_lambert_conf(self,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) implicit none ! - class(ip_lambert_conf_grid), intent(in) :: self - integer, intent(in) :: iopt, npts - integer, intent(out) :: nret + class(ip_lambert_conf_grid),intent(in) :: self + integer,intent(in) :: iopt,npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(npts), rlat(npts) - real, intent(inout) :: xpts(npts), ypts(npts) - real, optional, intent(out) :: crot(npts), srot(npts) - real, optional, intent(out) :: xlon(npts), xlat(npts) - real, optional, intent(out) :: ylon(npts), ylat(npts), area(npts) + real,intent(in) :: fill + real,intent(inout) :: rlon(npts),rlat(npts) + real,intent(inout) :: xpts(npts),ypts(npts) + real,optional,intent(out) :: crot(npts),srot(npts) + real,optional,intent(out) :: xlon(npts),xlat(npts) + real,optional,intent(out) :: ylon(npts),ylat(npts),area(npts) ! - integer :: im, jm, n + integer :: im,jm,n ! - logical :: lrot, lmap, larea + logical :: lrot,lmap,larea ! - real :: antr, di, dj + real :: antr,di,dj real :: dlon1 - real :: de, de2, dr2 - real :: orient, rlat1, rlon1 - real :: rlati1, rlati2 - real :: xmax, xmin, ymax, ymin, xp, yp - real :: dlon, dr + real :: de,de2,dr2 + real :: orient,rlat1,rlon1 + real :: rlati1,rlati2 + real :: xmax,xmin,ymax,ymin,xp,yp + real :: dlon,dr ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (present(crot)) crot = fill - if (present(srot)) srot = fill - if (present(xlon)) xlon = fill - if (present(xlat)) xlat = fill - if (present(ylon)) ylon = fill - if (present(ylat)) ylat = fill - if (present(area)) area = fill + if(present(crot)) crot=fill + if(present(srot)) srot=fill + if(present(xlon)) xlon=fill + if(present(xlat)) xlat=fill + if(present(ylon)) ylon=fill + if(present(ylat)) ylat=fill + if(present(area)) area=fill - im = self%im - jm = self%jm + im=self%im + jm=self%jm - rlat1 = self%rlat1 - rlon1 = self%rlon1 + rlat1=self%rlat1 + rlon1=self%rlon1 - irot = self%irot - orient = self%orient + irot=self%irot + orient=self%orient - rlati1 = self%rlati1 - rlati2 = self%rlati2 + rlati1=self%rlati1 + rlati2=self%rlati2 - h = self%h - dxs = self%dxs - dys = self%dys + h=self%h + dxs=self%dxs + dys=self%dys - rerth = self%rerth + rerth=self%rerth - if (abs(rlati1-rlati2) .lt. tinyreal) then - an = sin(rlati1/dpr) + if(abs(rlati1-rlati2).lt.tinyreal) then + an=sin(rlati1/dpr) else - an = log(cos(rlati1/dpr)/cos(rlati2/dpr))/ & - log(tan((90-rlati1)/2/dpr)/tan((90-rlati2)/2/dpr)) - end if - de = rerth*cos(rlati1/dpr)*tan((rlati1+90)/2/dpr)**an/an - if (abs(h*rlat1-90) .lt. tinyreal) then - xp = 1 - yp = 1 + an=log(cos(rlati1/dpr)/cos(rlati2/dpr))/ & + log(tan((90-rlati1)/2/dpr)/tan((90-rlati2)/2/dpr)) + endif + de=rerth*cos(rlati1/dpr)*tan((rlati1+90)/2/dpr)**an/an + if(abs(h*rlat1-90).lt.tinyreal) then + xp=1 + yp=1 else - dr = de/tan((rlat1+90)/2/dpr)**an - dlon1 = mod(rlon1-orient+180+3600, 360.)-180 - xp = 1-sin(an*dlon1/dpr)*dr/dxs - yp = 1+cos(an*dlon1/dpr)*dr/dys - end if - antr = 1/(2*an) - de2 = de**2 - xmin = 0 - xmax = im+1 - ymin = 0 - ymax = jm+1 - nret = 0 - if (present(crot) .and. present(srot)) then - lrot = .true. + dr=de/tan((rlat1+90)/2/dpr)**an + dlon1=mod(rlon1-orient+180+3600,360.)-180 + xp=1-sin(an*dlon1/dpr)*dr/dxs + yp=1+cos(an*dlon1/dpr)*dr/dys + endif + antr=1/(2*an) + de2=de**2 + xmin=0 + xmax=im+1 + ymin=0 + ymax=jm+1 + nret=0 + if(present(crot).and.present(srot)) then + lrot=.true. else - lrot = .false. - end if - if (present(xlon) .and. present(xlat) .and. present(ylon) .and. present(ylat)) then - lmap = .true. + lrot=.false. + endif + if(present(xlon).and.present(xlat).and.present(ylon).and.present(ylat)) then + lmap=.true. else - lmap = .false. - end if - if (present(area)) then - larea = .true. + lmap=.false. + endif + if(present(area)) then + larea=.true. else - larea = .false. - end if + larea=.false. + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSLATE GRID COORDINATES TO EARTH COORDINATES - if (iopt .eq. 0 .or. iopt .eq. 1) then - !$omp parallel do private(n, di, dj, dr2, dr, dlon) reduction(+:nret) schedule(static) - do n = 1, npts - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - di = h*(xpts(n)-xp)*dxs - dj = h*(ypts(n)-yp)*dys - dr2 = di**2+dj**2 - dr = sqrt(dr2) - if (dr2 .lt. de2*1.e-6) then - rlon(n) = 0. - rlat(n) = h*90. + if(iopt.eq.0.or.iopt.eq.1) then + !$omp parallel do private(n,di,dj,dr2,dr,dlon) reduction(+:nret) schedule(static) + do n=1,npts + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + di=h*(xpts(n)-xp)*dxs + dj=h*(ypts(n)-yp)*dys + dr2=di**2+dj**2 + dr=sqrt(dr2) + if(dr2.lt.de2*1.e-6) then + rlon(n)=0. + rlat(n)=h*90. else - rlon(n) = mod(orient+1./an*dpr*atan2(di, -dj)+3600, 360.) - rlat(n) = (2*dpr*atan((de2/dr2)**antr)-90) - end if - nret = nret+1 - dlon = mod(rlon(n)-orient+180+3600, 360.)-180 - if (lrot) call lambert_conf_vect_rot(dlon, crot(n), srot(n)) - if (lmap) call lambert_conf_map_jacob(rlat(n), fill, dlon, dr, & - xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call lambert_conf_grid_area(rlat(n), fill, dr, area(n)) + rlon(n)=mod(orient+1./an*dpr*atan2(di,-dj)+3600,360.) + rlat(n)=(2*dpr*atan((de2/dr2)**antr)-90) + endif + nret=nret+1 + dlon=mod(rlon(n)-orient+180+3600,360.)-180 + if(lrot) call lambert_conf_vect_rot(dlon,crot(n),srot(n)) + if(lmap) call lambert_conf_map_jacob(rlat(n),fill,dlon,dr, & + xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call lambert_conf_grid_area(rlat(n),fill,dr,area(n)) else - rlon(n) = fill - rlat(n) = fill - end if - end do + rlon(n)=fill + rlat(n)=fill + endif + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSLATE EARTH COORDINATES TO GRID COORDINATES - elseif (iopt .eq. -1) then - !$omp parallel do private(n, dr, dlon) reduction(+:nret) schedule(static) - do n = 1, npts - if (abs(rlon(n)) .lt. (360.+tinyreal) .and. abs(rlat(n)) .lt. (90.+tinyreal) .and. & - abs(h*rlat(n)+90) .gt. tinyreal) then - dr = h*de*tan((90-rlat(n))/2/dpr)**an - dlon = mod(rlon(n)-orient+180+3600, 360.)-180 - xpts(n) = xp+h*sin(an*dlon/dpr)*dr/dxs - ypts(n) = yp-h*cos(an*dlon/dpr)*dr/dys - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - nret = nret+1 - if (lrot) call lambert_conf_vect_rot(dlon, crot(n), srot(n)) - if (lmap) call lambert_conf_map_jacob(rlat(n), fill, dlon, dr, & - xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call lambert_conf_grid_area(rlat(n), fill, dr, area(n)) + elseif(iopt.eq.-1) then + !$omp parallel do private(n,dr,dlon) reduction(+:nret) schedule(static) + do n=1,npts + if(abs(rlon(n)).lt.(360.+tinyreal).and.abs(rlat(n)).lt.(90.+tinyreal).and. & + abs(h*rlat(n)+90).gt.tinyreal) then + dr=h*de*tan((90-rlat(n))/2/dpr)**an + dlon=mod(rlon(n)-orient+180+3600,360.)-180 + xpts(n)=xp+h*sin(an*dlon/dpr)*dr/dxs + ypts(n)=yp-h*cos(an*dlon/dpr)*dr/dys + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + nret=nret+1 + if(lrot) call lambert_conf_vect_rot(dlon,crot(n),srot(n)) + if(lmap) call lambert_conf_map_jacob(rlat(n),fill,dlon,dr, & + xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call lambert_conf_grid_area(rlat(n),fill,dr,area(n)) else - xpts(n) = fill - ypts(n) = fill - end if + xpts(n)=fill + ypts(n)=fill + endif else - xpts(n) = fill - ypts(n) = fill - end if - end do + xpts(n)=fill + ypts(n)=fill + endif + enddo !$omp end parallel do - end if + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine gdswzd_lambert_conf + endsubroutine gdswzd_lambert_conf !> Vector rotation fields for lambert conformal conical. !> @@ -386,20 +386,20 @@ end subroutine gdswzd_lambert_conf !> (ugrid=crot*uearth-srot*vearth; vgrid=srot*uearth+crot*vearth) !> !> @author Gayno @date 2015-01-21 - subroutine lambert_conf_vect_rot(dlon, crot, srot) + subroutine lambert_conf_vect_rot(dlon,crot,srot) implicit none - real, intent(in) :: dlon - real, intent(out) :: crot, srot + real,intent(in) :: dlon + real,intent(out) :: crot,srot - if (irot .eq. 1) then - crot = cos(an*dlon/dpr) - srot = sin(an*dlon/dpr) + if(irot.eq.1) then + crot=cos(an*dlon/dpr) + srot=sin(an*dlon/dpr) else - crot = 1. - srot = 0. - end if + crot=1. + srot=0. + endif - end subroutine lambert_conf_vect_rot + endsubroutine lambert_conf_vect_rot !> Map jacobians for lambert conformal conical. !> @@ -423,28 +423,28 @@ end subroutine lambert_conf_vect_rot !> @param[out] ylat dy/dlat in 1/degrees (real) !> !> @author Gayno @date 2015-01-21 - subroutine lambert_conf_map_jacob(rlat, fill, dlon, dr, xlon, xlat, ylon, ylat) + subroutine lambert_conf_map_jacob(rlat,fill,dlon,dr,xlon,xlat,ylon,ylat) implicit none - real, intent(in) :: rlat, fill, dlon, dr - real, intent(out) :: xlon, xlat, ylon, ylat + real,intent(in) :: rlat,fill,dlon,dr + real,intent(out) :: xlon,xlat,ylon,ylat real :: clat - clat = cos(rlat/dpr) - if (clat .le. 0 .or. dr .le. 0) then - xlon = fill - xlat = fill - ylon = fill - ylat = fill + clat=cos(rlat/dpr) + if(clat.le.0.or.dr.le.0) then + xlon=fill + xlat=fill + ylon=fill + ylat=fill else - xlon = h*cos(an*dlon/dpr)*an/dpr*dr/dxs - xlat = -h*sin(an*dlon/dpr)*an/dpr*dr/dxs/clat - ylon = h*sin(an*dlon/dpr)*an/dpr*dr/dys - ylat = h*cos(an*dlon/dpr)*an/dpr*dr/dys/clat - end if + xlon=h*cos(an*dlon/dpr)*an/dpr*dr/dxs + xlat=-h*sin(an*dlon/dpr)*an/dpr*dr/dxs/clat + ylon=h*sin(an*dlon/dpr)*an/dpr*dr/dys + ylat=h*cos(an*dlon/dpr)*an/dpr*dr/dys/clat + endif - end subroutine lambert_conf_map_jacob + endsubroutine lambert_conf_map_jacob !> Grid box area for lambert conformal conical. !> @@ -464,24 +464,24 @@ end subroutine lambert_conf_map_jacob !> @param[out] area area weights in m**2 (real) !> !> @author Gayno @date 2015-01-21 - subroutine lambert_conf_grid_area(rlat, fill, dr, area) + subroutine lambert_conf_grid_area(rlat,fill,dr,area) implicit none - real, intent(in) :: rlat - real, intent(in) :: fill - real, intent(in) :: dr - real, intent(out) :: area + real,intent(in) :: rlat + real,intent(in) :: fill + real,intent(in) :: dr + real,intent(out) :: area real :: clat - clat = cos(rlat/dpr) - if (clat .le. 0 .or. dr .le. 0) then - area = fill + clat=cos(rlat/dpr) + if(clat.le.0.or.dr.le.0) then + area=fill else - area = rerth**2*clat**2*abs(dxs)*abs(dys)/(an*dr)**2 - end if + area=rerth**2*clat**2*abs(dxs)*abs(dys)/(an*dr)**2 + endif - end subroutine lambert_conf_grid_area + endsubroutine lambert_conf_grid_area -end module ip_lambert_conf_grid_mod +endmodule ip_lambert_conf_grid_mod diff --git a/src/ip_mercator_grid_mod.F90 b/src/ip_mercator_grid_mod.F90 index 706fc396..1ecff266 100644 --- a/src/ip_mercator_grid_mod.F90 +++ b/src/ip_mercator_grid_mod.F90 @@ -12,14 +12,14 @@ module ip_mercator_grid_mod use ip_grid_descriptor_mod use ip_grid_mod - use ip_constants_mod, only: dpr, pi + use ip_constants_mod,only:dpr,pi use earth_radius_mod implicit none private public :: ip_mercator_grid - type, extends(ip_grid) :: ip_mercator_grid + type,extends(ip_grid) :: ip_mercator_grid real :: rlat1 !< Latitude of first grid point. Section 3, octets 39-42. real :: rlon1 !< Longitude of first grid point. Section 3, octets 43-46. real :: rlon2 !< Longitude of last grid point. Section 3, octets 56-59. @@ -34,8 +34,8 @@ module ip_mercator_grid_mod procedure :: init_grib2 !> Calculates Earth coordinates (iopt = 1) or grid coorindates (iopt = -1) !> for Gaussian grids. @return N/A - procedure :: gdswzd => gdswzd_mercator !< gdswzd() @return N/A - end type ip_mercator_grid + procedure :: gdswzd=>gdswzd_mercator !< gdswzd() @return N/A + endtype ip_mercator_grid real :: dlon !< Longitudinal direction grid length. real :: dphi !< Latitudinal direction grid length. @@ -49,47 +49,47 @@ module ip_mercator_grid_mod !> @param[in] g1_desc GRIB1 descriptor. !> !> @author Iredell @date 96-04-10 - subroutine init_grib1(self, g1_desc) - class(ip_mercator_grid), intent(inout) :: self - type(grib1_descriptor), intent(in) :: g1_desc + subroutine init_grib1(self,g1_desc) + class(ip_mercator_grid),intent(inout) :: self + type(grib1_descriptor),intent(in) :: g1_desc - integer :: iscan, jscan - real :: dy, hj + integer :: iscan,jscan + real :: dy,hj - associate (kgds => g1_desc%gds) - self%rerth = 6.3712e6 - self%eccen_squared = 0.0 + associate(kgds=>g1_desc%gds) + self%rerth=6.3712e6 + self%eccen_squared=0.0 - self%im = kgds(2) - self%jm = kgds(3) + self%im=kgds(2) + self%jm=kgds(3) - self%rlat1 = kgds(4)*1.e-3 - self%rlon1 = kgds(5)*1.e-3 - self%rlon2 = kgds(8)*1.e-3 - self%rlati = kgds(9)*1.e-3 + self%rlat1=kgds(4)*1.e-3 + self%rlon1=kgds(5)*1.e-3 + self%rlon2=kgds(8)*1.e-3 + self%rlati=kgds(9)*1.e-3 - iscan = mod(kgds(11)/128, 2) - jscan = mod(kgds(11)/64, 2) + iscan=mod(kgds(11)/128,2) + jscan=mod(kgds(11)/64,2) - dy = kgds(13) - self%hi = (-1.)**iscan - hj = (-1.)**(1-jscan) - self%dlon = self%hi*(mod(self%hi*(self%rlon2-self%rlon1)-1+3600, 360.)+1)/(self%im-1) - self%dphi = hj*dy/(self%rerth*cos(self%rlati/dpr)) + dy=kgds(13) + self%hi=(-1.)**iscan + hj=(-1.)**(1-jscan) + self%dlon=self%hi*(mod(self%hi*(self%rlon2-self%rlon1)-1+3600,360.)+1)/(self%im-1) + self%dphi=hj*dy/(self%rerth*cos(self%rlati/dpr)) ! defaults - self%iwrap = 0 - self%jwrap1 = 0 - self%jwrap2 = 0 - self%nscan = mod(kgds(11)/32, 2) - self%nscan_field_pos = self%nscan - self%kscan = 0 + self%iwrap=0 + self%jwrap1=0 + self%jwrap2=0 + self%nscan=mod(kgds(11)/32,2) + self%nscan_field_pos=self%nscan + self%kscan=0 - self%iwrap = nint(360/abs(self%dlon)) - if (self%im .lt. self%iwrap) self%iwrap = 0 - end associate + self%iwrap=nint(360/abs(self%dlon)) + if(self%im.lt.self%iwrap) self%iwrap=0 + endassociate - end subroutine init_grib1 + endsubroutine init_grib1 !> Init GRIB2. !> @@ -97,45 +97,45 @@ end subroutine init_grib1 !> @param[in] g2_desc GRIB2 descriptor. !> !> @author Iredell @date 96-04-10 - subroutine init_grib2(self, g2_desc) - class(ip_mercator_grid), intent(inout) :: self - type(grib2_descriptor), intent(in) :: g2_desc + subroutine init_grib2(self,g2_desc) + class(ip_mercator_grid),intent(inout) :: self + type(grib2_descriptor),intent(in) :: g2_desc - integer :: iscan, jscan - real :: hj, dy + integer :: iscan,jscan + real :: hj,dy - associate (igdtmpl => g2_desc%gdt_tmpl, igdtlen => g2_desc%gdt_len) + associate(igdtmpl=>g2_desc%gdt_tmpl,igdtlen=>g2_desc%gdt_len) - call earth_radius(igdtmpl, igdtlen, self%rerth, self%eccen_squared) + call earth_radius(igdtmpl,igdtlen,self%rerth,self%eccen_squared) - self%im = igdtmpl(8) - self%jm = igdtmpl(9) + self%im=igdtmpl(8) + self%jm=igdtmpl(9) - self%rlat1 = float(igdtmpl(10))*1.0e-6 - self%rlon1 = float(igdtmpl(11))*1.0e-6 - self%rlon2 = float(igdtmpl(15))*1.0e-6 - self%rlati = float(igdtmpl(13))*1.0e-6 + self%rlat1=float(igdtmpl(10))*1.0e-6 + self%rlon1=float(igdtmpl(11))*1.0e-6 + self%rlon2=float(igdtmpl(15))*1.0e-6 + self%rlati=float(igdtmpl(13))*1.0e-6 - iscan = mod(igdtmpl(16)/128, 2) - jscan = mod(igdtmpl(16)/64, 2) + iscan=mod(igdtmpl(16)/128,2) + jscan=mod(igdtmpl(16)/64,2) - dy = float(igdtmpl(19))*1.0e-3 - self%hi = (-1.)**iscan - hj = (-1.)**(1-jscan) - self%dlon = self%hi*(mod(self%hi*(self%rlon2-self%rlon1)-1+3600, 360.)+1)/(self%im-1) - self%dphi = hj*dy/(self%rerth*cos(self%rlati/dpr)) + dy=float(igdtmpl(19))*1.0e-3 + self%hi=(-1.)**iscan + hj=(-1.)**(1-jscan) + self%dlon=self%hi*(mod(self%hi*(self%rlon2-self%rlon1)-1+3600,360.)+1)/(self%im-1) + self%dphi=hj*dy/(self%rerth*cos(self%rlati/dpr)) - self%jwrap1 = 0 - self%jwrap2 = 0 - self%kscan = 0 - self%nscan = mod(igdtmpl(16)/32, 2) - self%nscan_field_pos = self%nscan + self%jwrap1=0 + self%jwrap2=0 + self%kscan=0 + self%nscan=mod(igdtmpl(16)/32,2) + self%nscan_field_pos=self%nscan - self%iwrap = nint(360/abs(self%dlon)) - if (self%im .lt. self%iwrap) self%iwrap = 0 + self%iwrap=nint(360/abs(self%dlon)) + if(self%im.lt.self%iwrap) self%iwrap=0 - end associate - end subroutine init_grib2 + endassociate + endsubroutine init_grib2 !> GDS wizard for mercator cylindrical. !> @@ -195,122 +195,122 @@ end subroutine init_grib2 !> (proportional to the square of the map factor) !> !> @author Iredell @date 96-04-10 - subroutine gdswzd_mercator(self, iopt, npts, fill, & - xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + subroutine gdswzd_mercator(self,iopt,npts,fill, & + xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) implicit none ! - class(ip_mercator_grid), intent(in) :: self - integer, intent(in) :: iopt, npts - integer, intent(out) :: nret + class(ip_mercator_grid),intent(in) :: self + integer,intent(in) :: iopt,npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(npts), rlat(npts) - real, intent(inout) :: xpts(npts), ypts(npts) - real, optional, intent(out) :: crot(npts), srot(npts) - real, optional, intent(out) :: xlon(npts), xlat(npts) - real, optional, intent(out) :: ylon(npts), ylat(npts), area(npts) + real,intent(in) :: fill + real,intent(inout) :: rlon(npts),rlat(npts) + real,intent(inout) :: xpts(npts),ypts(npts) + real,optional,intent(out) :: crot(npts),srot(npts) + real,optional,intent(out) :: xlon(npts),xlat(npts) + real,optional,intent(out) :: ylon(npts),ylat(npts),area(npts) ! - integer :: im, jm, n + integer :: im,jm,n ! - logical :: lrot, lmap, larea + logical :: lrot,lmap,larea ! real :: hi - real :: rlat1, rlon1, rlon2, rlati - real :: xmax, xmin, ymax, ymin + real :: rlat1,rlon1,rlon2,rlati + real :: xmax,xmin,ymax,ymin real :: ye ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (present(crot)) crot = fill - if (present(srot)) srot = fill - if (present(xlon)) xlon = fill - if (present(xlat)) xlat = fill - if (present(ylon)) ylon = fill - if (present(ylat)) ylat = fill - if (present(area)) area = fill + if(present(crot)) crot=fill + if(present(srot)) srot=fill + if(present(xlon)) xlon=fill + if(present(xlat)) xlat=fill + if(present(ylon)) ylon=fill + if(present(ylat)) ylat=fill + if(present(area)) area=fill ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - im = self%im - jm = self%jm - - rlat1 = self%rlat1 - rlon1 = self%rlon1 - rlon2 = self%rlon2 - rlati = self%rlati - - hi = self%hi - - dlon = self%dlon - dphi = self%dphi - rerth = self%rerth - - ye = 1-log(tan((rlat1+90)/2/dpr))/dphi - xmin = 0 - xmax = im+1 - if (im .eq. nint(360/abs(dlon))) xmax = im+2 - ymin = 0 - ymax = jm+1 - nret = 0 - if (present(crot) .and. present(srot)) then - lrot = .true. + im=self%im + jm=self%jm + + rlat1=self%rlat1 + rlon1=self%rlon1 + rlon2=self%rlon2 + rlati=self%rlati + + hi=self%hi + + dlon=self%dlon + dphi=self%dphi + rerth=self%rerth + + ye=1-log(tan((rlat1+90)/2/dpr))/dphi + xmin=0 + xmax=im+1 + if(im.eq.nint(360/abs(dlon))) xmax=im+2 + ymin=0 + ymax=jm+1 + nret=0 + if(present(crot).and.present(srot)) then + lrot=.true. else - lrot = .false. - end if - if (present(xlon) .and. present(xlat) .and. present(ylon) .and. present(ylat)) then - lmap = .true. + lrot=.false. + endif + if(present(xlon).and.present(xlat).and.present(ylon).and.present(ylat)) then + lmap=.true. else - lmap = .false. - end if - if (present(area)) then - larea = .true. + lmap=.false. + endif + if(present(area)) then + larea=.true. else - larea = .false. - end if + larea=.false. + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSLATE GRID COORDINATES TO EARTH COORDINATES - if (iopt .eq. 0 .or. iopt .eq. 1) then + if(iopt.eq.0.or.iopt.eq.1) then !$omp parallel do private(n) reduction(+:nret) schedule(static) - do n = 1, npts - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - rlon(n) = mod(rlon1+dlon*(xpts(n)-1)+3600, 360.) - rlat(n) = 2*atan(exp(dphi*(ypts(n)-ye)))*dpr-90 - nret = nret+1 - if (lrot) call mercator_vect_rot(crot(n), srot(n)) - if (lmap) call mercator_map_jacob(rlat(n), xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call mercator_grid_area(rlat(n), area(n)) + do n=1,npts + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + rlon(n)=mod(rlon1+dlon*(xpts(n)-1)+3600,360.) + rlat(n)=2*atan(exp(dphi*(ypts(n)-ye)))*dpr-90 + nret=nret+1 + if(lrot) call mercator_vect_rot(crot(n),srot(n)) + if(lmap) call mercator_map_jacob(rlat(n),xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call mercator_grid_area(rlat(n),area(n)) else - rlon(n) = fill - rlat(n) = fill - end if - end do + rlon(n)=fill + rlat(n)=fill + endif + enddo !$omp end parallel do ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSLATE EARTH COORDINATES TO GRID COORDINATES - elseif (iopt .eq. -1) then + elseif(iopt.eq.-1) then !$omp parallel do private(n) reduction(+:nret) schedule(static) - do n = 1, npts - if (abs(rlon(n)) .le. 360 .and. abs(rlat(n)) .lt. 90) then - xpts(n) = 1+hi*mod(hi*(rlon(n)-rlon1)+3600, 360.)/dlon - ypts(n) = ye+log(tan((rlat(n)+90)/2/dpr))/dphi - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - nret = nret+1 - if (lrot) call mercator_vect_rot(crot(n), srot(n)) - if (lmap) call mercator_map_jacob(rlat(n), xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call mercator_grid_area(rlat(n), area(n)) + do n=1,npts + if(abs(rlon(n)).le.360.and.abs(rlat(n)).lt.90) then + xpts(n)=1+hi*mod(hi*(rlon(n)-rlon1)+3600,360.)/dlon + ypts(n)=ye+log(tan((rlat(n)+90)/2/dpr))/dphi + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + nret=nret+1 + if(lrot) call mercator_vect_rot(crot(n),srot(n)) + if(lmap) call mercator_map_jacob(rlat(n),xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call mercator_grid_area(rlat(n),area(n)) else - xpts(n) = fill - ypts(n) = fill - end if + xpts(n)=fill + ypts(n)=fill + endif else - xpts(n) = fill - ypts(n) = fill - end if - end do + xpts(n)=fill + ypts(n)=fill + endif + enddo !$omp end parallel do - end if + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine gdswzd_mercator + endsubroutine gdswzd_mercator !> Vector rotation fields for mercator cylindrical grids. !> @@ -328,15 +328,15 @@ end subroutine gdswzd_mercator !> (ugrid=crot*uearth-srot*vearth; vgrid=srot*uearth+crot*vearth) !> !> @author Gayno @date 2015-01-21 - subroutine mercator_vect_rot(crot, srot) + subroutine mercator_vect_rot(crot,srot) implicit none - real, intent(out) :: crot, srot + real,intent(out) :: crot,srot - crot = 1.0 - srot = 0.0 + crot=1.0 + srot=0.0 - end subroutine mercator_vect_rot + endsubroutine mercator_vect_rot !> Map jacobians for mercator cylindrical grids. !> @@ -356,18 +356,18 @@ end subroutine mercator_vect_rot !> @param[out] ylat dy/dlat in 1/degrees (real) !> !> @author Gayno @date 2015-01-21 - subroutine mercator_map_jacob(rlat, xlon, xlat, ylon, ylat) + subroutine mercator_map_jacob(rlat,xlon,xlat,ylon,ylat) implicit none - real, intent(in) :: rlat - real, intent(out) :: xlon, xlat, ylon, ylat + real,intent(in) :: rlat + real,intent(out) :: xlon,xlat,ylon,ylat - xlon = 1./dlon - xlat = 0. - ylon = 0. - ylat = 1./dphi/cos(rlat/dpr)/dpr + xlon=1./dlon + xlat=0. + ylon=0. + ylat=1./dphi/cos(rlat/dpr)/dpr - end subroutine mercator_map_jacob + endsubroutine mercator_map_jacob !> Grid box area for mercator cylindrical grids. !> @@ -384,15 +384,15 @@ end subroutine mercator_map_jacob !> @param[out] area area weights in m**2 (real) !> !> @author Gayno @date 2015-01-21 - subroutine mercator_grid_area(rlat, area) + subroutine mercator_grid_area(rlat,area) implicit none - real, intent(in) :: rlat - real, intent(out) :: area + real,intent(in) :: rlat + real,intent(out) :: area - area = rerth**2*cos(rlat/dpr)**2*dphi*dlon/dpr + area=rerth**2*cos(rlat/dpr)**2*dphi*dlon/dpr - end subroutine mercator_grid_area + endsubroutine mercator_grid_area -end module ip_mercator_grid_mod +endmodule ip_mercator_grid_mod diff --git a/src/ip_mod.F90 b/src/ip_mod.F90 index 23a48cb2..e38c8ed4 100644 --- a/src/ip_mod.F90 +++ b/src/ip_mod.F90 @@ -7,14 +7,14 @@ module ip_mod ! Make these constants public to everyone instead of ! using numbers directly - use ip_interpolators_mod, only: bilinear_interp_id, & - bicubic_interp_id, & - neighbor_interp_id, & - budget_interp_id, & - spectral_interp_id, & - neighbor_budget_interp_id + use ip_interpolators_mod,only:bilinear_interp_id, & + bicubic_interp_id, & + neighbor_interp_id, & + budget_interp_id, & + spectral_interp_id, & + neighbor_budget_interp_id use ipolates_mod use ipolatev_mod use gdswzd_mod -end module ip_mod +endmodule ip_mod diff --git a/src/ip_polar_stereo_grid_mod.F90 b/src/ip_polar_stereo_grid_mod.F90 index 1395eb99..97132c27 100644 --- a/src/ip_polar_stereo_grid_mod.F90 +++ b/src/ip_polar_stereo_grid_mod.F90 @@ -13,14 +13,14 @@ module ip_polar_stereo_grid_mod use ip_grid_descriptor_mod use ip_grid_mod - use ip_constants_mod, only: dpr, pi, pi2, pi4, rerth_wgs84, e2_wgs84 + use ip_constants_mod,only:dpr,pi,pi2,pi4,rerth_wgs84,e2_wgs84 use earth_radius_mod implicit none private public :: ip_polar_stereo_grid - type, extends(ip_grid) :: ip_polar_stereo_grid + type,extends(ip_grid) :: ip_polar_stereo_grid logical :: elliptical !< When true/false, computations are based on an elliptical/spherical earth. real :: rlat1 !< Latitude of the first grid point. real :: rlon1 !< Longitude of the first grid point. @@ -38,8 +38,8 @@ module ip_polar_stereo_grid_mod procedure :: init_grib2 !< Initializes a grid given a grib2_descriptor object. @return N/A !> Calculates Earth coordinates (iopt = 1) or grid coorindates !> (iopt = -1). @return N/A - procedure :: gdswzd => gdswzd_polar_stereo - end type ip_polar_stereo_grid + procedure :: gdswzd=>gdswzd_polar_stereo + endtype ip_polar_stereo_grid integer :: irot !< Local copy of irot. real :: de2 !< Square of DE. @@ -49,7 +49,7 @@ module ip_polar_stereo_grid_mod real :: rerth !< Radius of the Earth. real :: h !< Local copy of h. real :: orient !< Local copy of orient. - real :: tinyreal = tiny(1.0) !< Smallest positive real value (use for equality comparisons) + real :: tinyreal=tiny(1.0) !< Smallest positive real value (use for equality comparisons) contains @@ -60,63 +60,63 @@ module ip_polar_stereo_grid_mod !! @param[in] g1_desc A grib1_descriptor !! !! @author Iredell @date 96-04-10 - subroutine init_grib1(self, g1_desc) - class(ip_polar_stereo_grid), intent(inout) :: self - type(grib1_descriptor), intent(in) :: g1_desc + subroutine init_grib1(self,g1_desc) + class(ip_polar_stereo_grid),intent(inout) :: self + type(grib1_descriptor),intent(in) :: g1_desc - real, parameter :: slat = 60.0 ! standard latitude according grib1 standard + real,parameter :: slat=60.0 ! standard latitude according grib1 standard - real :: dx, dy, hi, hj - integer :: iproj, iscan, jscan + real :: dx,dy,hi,hj + integer :: iproj,iscan,jscan - associate (kgds => g1_desc%gds) - self%elliptical = mod(kgds(6)/64, 2) .eq. 1 + associate(kgds=>g1_desc%gds) + self%elliptical=mod(kgds(6)/64,2).eq.1 - if (.not. self%elliptical) then - self%rerth = 6.3712e6 - self%eccen_squared = 0d0 + if(.not.self%elliptical) then + self%rerth=6.3712e6 + self%eccen_squared=0d0 else - self%rerth = rerth_wgs84 - self%eccen_squared = e2_wgs84 !wgs84 datum - end if + self%rerth=rerth_wgs84 + self%eccen_squared=e2_wgs84 !wgs84 datum + endif - self%im = kgds(2) - self%jm = kgds(3) + self%im=kgds(2) + self%jm=kgds(3) - self%rlat1 = kgds(4)*1.e-3 - self%rlon1 = kgds(5)*1.e-3 + self%rlat1=kgds(4)*1.e-3 + self%rlon1=kgds(5)*1.e-3 - self%irot = mod(kgds(6)/8, 2) + self%irot=mod(kgds(6)/8,2) - self%slatr = slat/dpr + self%slatr=slat/dpr - self%orient = kgds(7)*1.e-3 + self%orient=kgds(7)*1.e-3 - dx = kgds(8) - dy = kgds(9) + dx=kgds(8) + dy=kgds(9) - iproj = mod(kgds(10)/128, 2) - iscan = mod(kgds(11)/128, 2) - jscan = mod(kgds(11)/64, 2) + iproj=mod(kgds(10)/128,2) + iscan=mod(kgds(11)/128,2) + jscan=mod(kgds(11)/64,2) - self%h = (-1.)**iproj - hi = (-1.)**iscan - hj = (-1.)**(1-jscan) + self%h=(-1.)**iproj + hi=(-1.)**iscan + hj=(-1.)**(1-jscan) - if (abs(self%h+1.) .lt. tinyreal) self%orient = self%orient+180. + if(abs(self%h+1.).lt.tinyreal) self%orient=self%orient+180. - self%dxs = dx*hi - self%dys = dy*hj + self%dxs=dx*hi + self%dys=dy*hj - self%iwrap = 0 - self%jwrap1 = 0 - self%jwrap2 = 0 - self%nscan = mod(kgds(11)/32, 2) - self%nscan_field_pos = self%nscan - self%kscan = 0 - end associate + self%iwrap=0 + self%jwrap1=0 + self%jwrap2=0 + self%nscan=mod(kgds(11)/32,2) + self%nscan_field_pos=self%nscan + self%kscan=0 + endassociate - end subroutine init_grib1 + endsubroutine init_grib1 !> Initializes a polar stereographic grid given a grib2_descriptor !! object. @@ -125,53 +125,53 @@ end subroutine init_grib1 !! @param[in] g2_desc A grib2_descriptor !! !! @author Iredell @date 96-04-10 - subroutine init_grib2(self, g2_desc) - class(ip_polar_stereo_grid), intent(inout) :: self - type(grib2_descriptor), intent(in) :: g2_desc + subroutine init_grib2(self,g2_desc) + class(ip_polar_stereo_grid),intent(inout) :: self + type(grib2_descriptor),intent(in) :: g2_desc - real :: slat, dx, dy, hi, hj - integer :: iproj, iscan, jscan + real :: slat,dx,dy,hi,hj + integer :: iproj,iscan,jscan - associate (igdtmpl => g2_desc%gdt_tmpl, igdtlen => g2_desc%gdt_len) - call earth_radius(igdtmpl, igdtlen, self%rerth, self%eccen_squared) + associate(igdtmpl=>g2_desc%gdt_tmpl,igdtlen=>g2_desc%gdt_len) + call earth_radius(igdtmpl,igdtlen,self%rerth,self%eccen_squared) - self%elliptical = self%eccen_squared .gt. 0.0 + self%elliptical=self%eccen_squared.gt.0.0 - self%im = igdtmpl(8) - self%jm = igdtmpl(9) + self%im=igdtmpl(8) + self%jm=igdtmpl(9) - self%rlat1 = float(igdtmpl(10))*1.e-6 - self%rlon1 = float(igdtmpl(11))*1.e-6 + self%rlat1=float(igdtmpl(10))*1.e-6 + self%rlon1=float(igdtmpl(11))*1.e-6 - self%irot = mod(igdtmpl(12)/8, 2) + self%irot=mod(igdtmpl(12)/8,2) - slat = float(abs(igdtmpl(13)))*1.e-6 - self%slatr = slat/dpr + slat=float(abs(igdtmpl(13)))*1.e-6 + self%slatr=slat/dpr - self%orient = float(igdtmpl(14))*1.e-6 + self%orient=float(igdtmpl(14))*1.e-6 - dx = float(igdtmpl(15))*1.e-3 - dy = float(igdtmpl(16))*1.e-3 + dx=float(igdtmpl(15))*1.e-3 + dy=float(igdtmpl(16))*1.e-3 - iproj = mod(igdtmpl(17)/128, 2) - iscan = mod(igdtmpl(18)/128, 2) - jscan = mod(igdtmpl(18)/64, 2) + iproj=mod(igdtmpl(17)/128,2) + iscan=mod(igdtmpl(18)/128,2) + jscan=mod(igdtmpl(18)/64,2) - self%h = (-1.)**iproj - hi = (-1.)**iscan - hj = (-1.)**(1-jscan) + self%h=(-1.)**iproj + hi=(-1.)**iscan + hj=(-1.)**(1-jscan) - self%dxs = dx*hi - self%dys = dy*hj + self%dxs=dx*hi + self%dys=dy*hj - self%nscan = mod(igdtmpl(18)/32, 2) - self%nscan_field_pos = self%nscan - self%iwrap = 0 - self%jwrap1 = 0 - self%jwrap2 = 0 - self%kscan = 0 - end associate - end subroutine init_grib2 + self%nscan=mod(igdtmpl(18)/32,2) + self%nscan_field_pos=self%nscan + self%iwrap=0 + self%jwrap1=0 + self%jwrap2=0 + self%kscan=0 + endassociate + endsubroutine init_grib2 !> GDS wizard for polar stereographic azimuthal !> @@ -236,229 +236,229 @@ end subroutine init_grib2 !> (proportional to the square of the map factor) !> !> @author Iredell @date 96-04-10 - subroutine gdswzd_polar_stereo(self, iopt, npts, & - fill, xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + subroutine gdswzd_polar_stereo(self,iopt,npts, & + fill,xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) implicit none ! - class(ip_polar_stereo_grid), intent(in) :: self - integer, intent(in) :: iopt, npts - integer, intent(out) :: nret + class(ip_polar_stereo_grid),intent(in) :: self + integer,intent(in) :: iopt,npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(npts), rlat(npts) - real, intent(inout) :: xpts(npts), ypts(npts) - real, optional, intent(out) :: crot(npts), srot(npts) - real, optional, intent(out) :: xlon(npts), xlat(npts) - real, optional, intent(out) :: ylon(npts), ylat(npts), area(npts) + real,intent(in) :: fill + real,intent(inout) :: rlon(npts),rlat(npts) + real,intent(inout) :: xpts(npts),ypts(npts) + real,optional,intent(out) :: crot(npts),srot(npts) + real,optional,intent(out) :: xlon(npts),xlat(npts) + real,optional,intent(out) :: ylon(npts),ylat(npts),area(npts) ! - integer :: im, jm - integer :: iter, n + integer :: im,jm + integer :: iter,n ! - logical :: elliptical, lrot, lmap, larea + logical :: elliptical,lrot,lmap,larea ! - real :: alat, alat1, along, diff - real :: di, dj, de - real :: dr, e, e_over_2 - real :: mc, slatr - real :: rlat1, rlon1, rho, t, tc - real :: xmax, xmin, ymax, ymin - real :: xp, yp, dr2 + real :: alat,alat1,along,diff + real :: di,dj,de + real :: dr,e,e_over_2 + real :: mc,slatr + real :: rlat1,rlon1,rho,t,tc + real :: xmax,xmin,ymax,ymin + real :: xp,yp,dr2 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (present(crot)) crot = fill - if (present(srot)) srot = fill - if (present(xlon)) xlon = fill - if (present(xlat)) xlat = fill - if (present(ylon)) ylon = fill - if (present(ylat)) ylat = fill - if (present(area)) area = fill - - elliptical = self%elliptical - im = self%im - jm = self%jm - - rlat1 = self%rlat1 - rlon1 = self%rlon1 - - irot = self%irot - slatr = self%slatr - orient = self%orient - - h = self%h - dxs = self%dxs - dys = self%dys - - rerth = self%rerth - e2 = self%eccen_squared + if(present(crot)) crot=fill + if(present(srot)) srot=fill + if(present(xlon)) xlon=fill + if(present(xlat)) xlat=fill + if(present(ylon)) ylon=fill + if(present(ylat)) ylat=fill + if(present(area)) area=fill + + elliptical=self%elliptical + im=self%im + jm=self%jm + + rlat1=self%rlat1 + rlon1=self%rlon1 + + irot=self%irot + slatr=self%slatr + orient=self%orient + + h=self%h + dxs=self%dxs + dys=self%dys + + rerth=self%rerth + e2=self%eccen_squared ! ! FIND X/Y OF POLE - if (.not. elliptical) then - de = (1.+sin(slatr))*rerth - dr = de*cos(rlat1/dpr)/(1+h*sin(rlat1/dpr)) - xp = 1-h*sin((rlon1-orient)/dpr)*dr/dxs - yp = 1+cos((rlon1-orient)/dpr)*dr/dys - de2 = de**2 + if(.not.elliptical) then + de=(1.+sin(slatr))*rerth + dr=de*cos(rlat1/dpr)/(1+h*sin(rlat1/dpr)) + xp=1-h*sin((rlon1-orient)/dpr)*dr/dxs + yp=1+cos((rlon1-orient)/dpr)*dr/dys + de2=de**2 else - e = sqrt(e2) - e_over_2 = e*0.5 - alat = h*rlat1/dpr - along = (rlon1-orient)/dpr - t = tan(pi4-alat/2.)/((1.-e*sin(alat))/ & - (1.+e*sin(alat)))**(e_over_2) - tc = tan(pi4-slatr/2.)/((1.-e*sin(slatr))/ & - (1.+e*sin(slatr)))**(e_over_2) - mc = cos(slatr)/sqrt(1.0-e2*(sin(slatr)**2)) - rho = rerth*mc*t/tc - yp = 1.0+rho*cos(h*along)/dys - xp = 1.0-rho*sin(h*along)/dxs - end if ! ELLIPTICAL - xmin = 0 - xmax = im+1 - ymin = 0 - ymax = jm+1 - nret = 0 - if (present(crot) .and. present(srot)) then - lrot = .true. + e=sqrt(e2) + e_over_2=e*0.5 + alat=h*rlat1/dpr + along=(rlon1-orient)/dpr + t=tan(pi4-alat/2.)/((1.-e*sin(alat))/ & + (1.+e*sin(alat)))**(e_over_2) + tc=tan(pi4-slatr/2.)/((1.-e*sin(slatr))/ & + (1.+e*sin(slatr)))**(e_over_2) + mc=cos(slatr)/sqrt(1.0-e2*(sin(slatr)**2)) + rho=rerth*mc*t/tc + yp=1.0+rho*cos(h*along)/dys + xp=1.0-rho*sin(h*along)/dxs + endif ! ELLIPTICAL + xmin=0 + xmax=im+1 + ymin=0 + ymax=jm+1 + nret=0 + if(present(crot).and.present(srot)) then + lrot=.true. else - lrot = .false. - end if - if (present(xlon) .and. present(xlat) .and. present(ylon) .and. present(ylat)) then - lmap = .true. + lrot=.false. + endif + if(present(xlon).and.present(xlat).and.present(ylon).and.present(ylat)) then + lmap=.true. else - lmap = .false. - end if - if (present(area)) then - larea = .true. + lmap=.false. + endif + if(present(area)) then + larea=.true. else - larea = .false. - end if + larea=.false. + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSLATE GRID COORDINATES TO EARTH COORDINATES - if (iopt .eq. 0 .or. iopt .eq. 1) then - if (.not. elliptical) then - !$omp parallel do private(n, di, dj, dr2) reduction(+:nret) schedule(static) - do n = 1, npts - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - di = (xpts(n)-xp)*dxs - dj = (ypts(n)-yp)*dys - dr2 = di**2+dj**2 - if (dr2 .lt. de2*1.e-6) then - rlon(n) = 0. - rlat(n) = h*90. + if(iopt.eq.0.or.iopt.eq.1) then + if(.not.elliptical) then + !$omp parallel do private(n,di,dj,dr2) reduction(+:nret) schedule(static) + do n=1,npts + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + di=(xpts(n)-xp)*dxs + dj=(ypts(n)-yp)*dys + dr2=di**2+dj**2 + if(dr2.lt.de2*1.e-6) then + rlon(n)=0. + rlat(n)=h*90. else - rlon(n) = mod(orient+h*dpr*atan2(di, -dj)+3600, 360.) - rlat(n) = h*dpr*asin((de2-dr2)/(de2+dr2)) - end if - nret = nret+1 - if (lrot) call polar_stereo_vect_rot(rlon(n), crot(n), srot(n)) - if (lmap) call polar_stereo_map_jacob(rlon(n), rlat(n), dr2, & - xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call polar_stereo_grid_area(rlat(n), dr2, area(n)) + rlon(n)=mod(orient+h*dpr*atan2(di,-dj)+3600,360.) + rlat(n)=h*dpr*asin((de2-dr2)/(de2+dr2)) + endif + nret=nret+1 + if(lrot) call polar_stereo_vect_rot(rlon(n),crot(n),srot(n)) + if(lmap) call polar_stereo_map_jacob(rlon(n),rlat(n),dr2, & + xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call polar_stereo_grid_area(rlat(n),dr2,area(n)) else - rlon(n) = fill - rlat(n) = fill - end if - end do + rlon(n)=fill + rlat(n)=fill + endif + enddo !$omp end parallel do else ! ELLIPTICAL - !$omp parallel do private(n, di, dj, rho, t, along, alat1, alat, diff) & + !$omp parallel do private(n,di,dj,rho,t,along,alat1,alat,diff) & !$omp&reduction(+:nret) schedule(static) - do n = 1, npts - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - di = (xpts(n)-xp)*dxs - dj = (ypts(n)-yp)*dys - rho = sqrt(di*di+dj*dj) - t = (rho*tc)/(rerth*mc) - if (abs(ypts(n)-yp) .lt. 0.01) then - if (di .gt. 0.0) along = orient+h*90.0 - if (di .le. 0.0) along = orient-h*90.0 + do n=1,npts + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + di=(xpts(n)-xp)*dxs + dj=(ypts(n)-yp)*dys + rho=sqrt(di*di+dj*dj) + t=(rho*tc)/(rerth*mc) + if(abs(ypts(n)-yp).lt.0.01) then + if(di.gt.0.0) along=orient+h*90.0 + if(di.le.0.0) along=orient-h*90.0 else - along = orient+h*atan(di/(-dj))*dpr - if (dj .gt. 0) along = along+180. - end if - alat1 = pi2-2.0*atan(t) - do iter = 1, 10 - alat = pi2-2.0*atan(t*(((1.0-e*sin(alat1))/ & - (1.0+e*sin(alat1)))**(e_over_2))) - diff = abs(alat-alat1)*dpr - if (diff .lt. 0.000001) exit - alat1 = alat - end do - rlat(n) = h*alat*dpr - rlon(n) = along - if (rlon(n) .lt. 0.0) rlon(n) = rlon(n)+360. - if (rlon(n) .gt. 360.0) rlon(n) = rlon(n)-360.0 - nret = nret+1 - if (lrot) call polar_stereo_vect_rot(rlon(n), crot(n), srot(n)) + along=orient+h*atan(di/(-dj))*dpr + if(dj.gt.0) along=along+180. + endif + alat1=pi2-2.0*atan(t) + do iter=1,10 + alat=pi2-2.0*atan(t*(((1.0-e*sin(alat1))/ & + (1.0+e*sin(alat1)))**(e_over_2))) + diff=abs(alat-alat1)*dpr + if(diff.lt.0.000001) exit + alat1=alat + enddo + rlat(n)=h*alat*dpr + rlon(n)=along + if(rlon(n).lt.0.0) rlon(n)=rlon(n)+360. + if(rlon(n).gt.360.0) rlon(n)=rlon(n)-360.0 + nret=nret+1 + if(lrot) call polar_stereo_vect_rot(rlon(n),crot(n),srot(n)) else - rlon(n) = fill - rlat(n) = fill - end if - end do + rlon(n)=fill + rlat(n)=fill + endif + enddo !$omp end parallel do - end if ! ELLIPTICAL + endif ! ELLIPTICAL ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSLATE EARTH COORDINATES TO GRID COORDINATES - elseif (iopt .eq. -1) then - if (.not. elliptical) then - !$omp parallel do private(n, dr, dr2) reduction(+:nret) schedule(static) - do n = 1, npts - if (abs(rlon(n)) .lt. (360.+tinyreal) .and. abs(rlat(n)) .lt. (90.+tinyreal) .and. & - abs(h*rlat(n)+90) .gt. tinyreal) then - dr = de*tan((90-h*rlat(n))/2/dpr) - dr2 = dr**2 - xpts(n) = xp+h*sin((rlon(n)-orient)/dpr)*dr/dxs - ypts(n) = yp-cos((rlon(n)-orient)/dpr)*dr/dys - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - nret = nret+1 - if (lrot) call polar_stereo_vect_rot(rlon(n), crot(n), srot(n)) - if (lmap) call polar_stereo_map_jacob(rlon(n), rlat(n), dr2, & - xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call polar_stereo_grid_area(rlat(n), dr2, area(n)) + elseif(iopt.eq.-1) then + if(.not.elliptical) then + !$omp parallel do private(n,dr,dr2) reduction(+:nret) schedule(static) + do n=1,npts + if(abs(rlon(n)).lt.(360.+tinyreal).and.abs(rlat(n)).lt.(90.+tinyreal).and. & + abs(h*rlat(n)+90).gt.tinyreal) then + dr=de*tan((90-h*rlat(n))/2/dpr) + dr2=dr**2 + xpts(n)=xp+h*sin((rlon(n)-orient)/dpr)*dr/dxs + ypts(n)=yp-cos((rlon(n)-orient)/dpr)*dr/dys + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + nret=nret+1 + if(lrot) call polar_stereo_vect_rot(rlon(n),crot(n),srot(n)) + if(lmap) call polar_stereo_map_jacob(rlon(n),rlat(n),dr2, & + xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call polar_stereo_grid_area(rlat(n),dr2,area(n)) else - xpts(n) = fill - ypts(n) = fill - end if + xpts(n)=fill + ypts(n)=fill + endif else - xpts(n) = fill - ypts(n) = fill - end if - end do + xpts(n)=fill + ypts(n)=fill + endif + enddo !$omp end parallel do else ! ELLIPTICAL CASE - !$omp parallel do private(n, alat, along, t, rho) reduction(+:nret) schedule(static) - do n = 1, npts - if (abs(rlon(n)) .lt. (360+tinyreal) .and. abs(rlat(n)) .lt. (90+tinyreal) .and. & - abs(h*rlat(n)+90) .gt. tinyreal) then - alat = h*rlat(n)/dpr - along = (rlon(n)-orient)/dpr - t = tan(pi4-alat*0.5)/((1.-e*sin(alat))/ & - (1.+e*sin(alat)))**(e_over_2) - rho = rerth*mc*t/tc - xpts(n) = xp+rho*sin(h*along)/dxs - ypts(n) = yp-rho*cos(h*along)/dys - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - nret = nret+1 - if (lrot) call polar_stereo_vect_rot(rlon(n), crot(n), srot(n)) + !$omp parallel do private(n,alat,along,t,rho) reduction(+:nret) schedule(static) + do n=1,npts + if(abs(rlon(n)).lt.(360+tinyreal).and.abs(rlat(n)).lt.(90+tinyreal).and. & + abs(h*rlat(n)+90).gt.tinyreal) then + alat=h*rlat(n)/dpr + along=(rlon(n)-orient)/dpr + t=tan(pi4-alat*0.5)/((1.-e*sin(alat))/ & + (1.+e*sin(alat)))**(e_over_2) + rho=rerth*mc*t/tc + xpts(n)=xp+rho*sin(h*along)/dxs + ypts(n)=yp-rho*cos(h*along)/dys + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + nret=nret+1 + if(lrot) call polar_stereo_vect_rot(rlon(n),crot(n),srot(n)) else - xpts(n) = fill - ypts(n) = fill - end if + xpts(n)=fill + ypts(n)=fill + endif else - xpts(n) = fill - ypts(n) = fill - end if - end do + xpts(n)=fill + ypts(n)=fill + endif + enddo !$omp end parallel do - end if - end if + endif + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine gdswzd_polar_stereo + endsubroutine gdswzd_polar_stereo !> Vector rotation fields for polar stereographic grids. !> @@ -479,21 +479,21 @@ end subroutine gdswzd_polar_stereo !> vgrid=srot*uearth+crot*vearth) !> !> @author Gayno @date 2015-01-21 - subroutine polar_stereo_vect_rot(rlon, crot, srot) + subroutine polar_stereo_vect_rot(rlon,crot,srot) implicit none - real, intent(in) :: rlon - real, intent(out) :: crot, srot + real,intent(in) :: rlon + real,intent(out) :: crot,srot - if (irot .eq. 1) then - crot = h*cos((rlon-orient)/dpr) - srot = sin((rlon-orient)/dpr) + if(irot.eq.1) then + crot=h*cos((rlon-orient)/dpr) + srot=sin((rlon-orient)/dpr) else - crot = 1. - srot = 0. - end if + crot=1. + srot=0. + endif - end subroutine polar_stereo_vect_rot + endsubroutine polar_stereo_vect_rot !> Map jacobians for polar stereographic grids. !> @@ -517,30 +517,30 @@ end subroutine polar_stereo_vect_rot !> @param[out] ylat dy/dlat in 1/degrees (real) !> !> @author Gayno @date 2015-01-21 - subroutine polar_stereo_map_jacob(rlon, rlat, dr2, xlon, xlat, ylon, ylat) + subroutine polar_stereo_map_jacob(rlon,rlat,dr2,xlon,xlat,ylon,ylat) implicit none - real, intent(in) :: rlon, rlat, dr2 - real, intent(out) :: xlon, xlat, ylon, ylat + real,intent(in) :: rlon,rlat,dr2 + real,intent(out) :: xlon,xlat,ylon,ylat - real :: clat, de, dr + real :: clat,de,dr - if (dr2 .lt. de2*1.e-6) then - de = sqrt(de2) - xlon = 0. - xlat = -sin((rlon-orient)/dpr)/dpr*de/dxs/2 - ylon = 0. - ylat = h*cos((rlon-orient)/dpr)/dpr*de/dys/2 + if(dr2.lt.de2*1.e-6) then + de=sqrt(de2) + xlon=0. + xlat=-sin((rlon-orient)/dpr)/dpr*de/dxs/2 + ylon=0. + ylat=h*cos((rlon-orient)/dpr)/dpr*de/dys/2 else - dr = sqrt(dr2) - clat = cos(rlat/dpr) - xlon = h*cos((rlon-orient)/dpr)/dpr*dr/dxs - xlat = -sin((rlon-orient)/dpr)/dpr*dr/dxs/clat - ylon = sin((rlon-orient)/dpr)/dpr*dr/dys - ylat = h*cos((rlon-orient)/dpr)/dpr*dr/dys/clat - end if + dr=sqrt(dr2) + clat=cos(rlat/dpr) + xlon=h*cos((rlon-orient)/dpr)/dpr*dr/dxs + xlat=-sin((rlon-orient)/dpr)/dpr*dr/dxs/clat + ylon=sin((rlon-orient)/dpr)/dpr*dr/dys + ylat=h*cos((rlon-orient)/dpr)/dpr*dr/dys/clat + endif - end subroutine polar_stereo_map_jacob + endsubroutine polar_stereo_map_jacob !> Grid box area for polar stereographic grids. !> @@ -560,21 +560,21 @@ end subroutine polar_stereo_map_jacob !> @param[out] area area weights in m**2 (real) !> !> @author Gayno @date 2015-01-21 - subroutine polar_stereo_grid_area(rlat, dr2, area) + subroutine polar_stereo_grid_area(rlat,dr2,area) implicit none - real, intent(in) :: rlat, dr2 - real, intent(out) :: area + real,intent(in) :: rlat,dr2 + real,intent(out) :: area real :: clat - if (dr2 .lt. de2*1.e-6) then - area = rerth**2*abs(dxs)*abs(dys)*4/de2 + if(dr2.lt.de2*1.e-6) then + area=rerth**2*abs(dxs)*abs(dys)*4/de2 else - clat = cos(rlat/dpr) - area = rerth**2*clat**2*abs(dxs)*abs(dys)/dr2 - end if + clat=cos(rlat/dpr) + area=rerth**2*clat**2*abs(dxs)*abs(dys)/dr2 + endif - end subroutine polar_stereo_grid_area + endsubroutine polar_stereo_grid_area -end module ip_polar_stereo_grid_mod +endmodule ip_polar_stereo_grid_mod diff --git a/src/ip_rot_equid_cylind_egrid_mod.F90 b/src/ip_rot_equid_cylind_egrid_mod.F90 index 6b465d09..167105a6 100644 --- a/src/ip_rot_equid_cylind_egrid_mod.F90 +++ b/src/ip_rot_equid_cylind_egrid_mod.F90 @@ -22,19 +22,19 @@ !> @author George Gayno, Mark Iredell, Kyle Gerheiser !> @date July 2021 module ip_rot_equid_cylind_egrid_mod - use iso_fortran_env, only: real64 + use iso_fortran_env,only:real64 use ip_grid_descriptor_mod use ip_grid_mod - use ip_constants_mod, only: dpr, pi + use ip_constants_mod,only:dpr,pi use earth_radius_mod implicit none private public :: ip_rot_equid_cylind_egrid - integer, parameter :: kd = real64 !< Kind of reals. + integer,parameter :: kd=real64 !< Kind of reals. - type, extends(ip_grid) :: ip_rot_equid_cylind_egrid + type,extends(ip_grid) :: ip_rot_equid_cylind_egrid real(kd) :: rlon0 !< Longitude of southern pole of projection. real(kd) :: rlon1 !< Longitude of first grid point. real(kd) :: rlat1 !< Latitude of first grid point. @@ -56,8 +56,8 @@ module ip_rot_equid_cylind_egrid_mod procedure :: init_grib2 !> Calculates Earth coordinates (iopt = 1) or grid coorindates !> (iopt = -1). @return N/A - procedure :: gdswzd => gdswzd_rot_equid_cylind_egrid - end type ip_rot_equid_cylind_egrid + procedure :: gdswzd=>gdswzd_rot_equid_cylind_egrid + endtype ip_rot_equid_cylind_egrid integer :: irot !< Local copy of irot. @@ -83,74 +83,74 @@ module ip_rot_equid_cylind_egrid_mod !> !> @author Kyle Gerheiser !> @date July 2021 - subroutine init_grib1(self, g1_desc) - class(ip_rot_equid_cylind_egrid), intent(inout) :: self - type(grib1_descriptor), intent(in) :: g1_desc + subroutine init_grib1(self,g1_desc) + class(ip_rot_equid_cylind_egrid),intent(inout) :: self + type(grib1_descriptor),intent(in) :: g1_desc integer :: iscan real(kd) :: rlat0 - real(kd) :: rlat1, rlon1, rlon0, slat1, clat1, slat0, clat0, clon1 - real(kd) :: slatr, clatr, clonr, rlatr, rlonr, dlats, dlons, hs, hi - integer :: im, jm - - integer :: is1, kscan, irot - - associate (kgds => g1_desc%gds) - self%rerth = 6.3712e6_kd - self%eccen_squared = 0.0 - - im = kgds(2) - jm = kgds(3) - - self%nscan_field_pos = 3 - self%nscan = mod(kgds(11)/32, 2) - - rlat1 = kgds(4)*1.e-3_kd - rlon1 = kgds(5)*1.e-3_kd - rlat0 = kgds(7)*1.e-3_kd - rlon0 = kgds(8)*1.e-3_kd - - irot = mod(kgds(6)/8, 2) - kscan = mod(kgds(11)/256, 2) - iscan = mod(kgds(11)/128, 2) - hi = (-1.)**iscan - slat1 = sin(rlat1/dpr) - clat1 = cos(rlat1/dpr) - slat0 = sin(rlat0/dpr) - clat0 = cos(rlat0/dpr) - hs = sign(1._kd, mod(rlon1-rlon0+180+3600, 360._kd)-180) - clon1 = cos((rlon1-rlon0)/dpr) - slatr = clat0*slat1-slat0*clat1*clon1 - clatr = sqrt(1-slatr**2) - clonr = (clat0*clat1*clon1+slat0*slat1)/clatr - rlatr = dpr*asin(slatr) - rlonr = hs*dpr*acos(clonr) - dlats = rlatr/(-(jm-1)/2) - dlons = rlonr/(-((im*2-1)-1)/2) - - if (kscan .eq. 0) then - is1 = (jm+1)/2 + real(kd) :: rlat1,rlon1,rlon0,slat1,clat1,slat0,clat0,clon1 + real(kd) :: slatr,clatr,clonr,rlatr,rlonr,dlats,dlons,hs,hi + integer :: im,jm + + integer :: is1,kscan,irot + + associate(kgds=>g1_desc%gds) + self%rerth=6.3712e6_kd + self%eccen_squared=0.0 + + im=kgds(2) + jm=kgds(3) + + self%nscan_field_pos=3 + self%nscan=mod(kgds(11)/32,2) + + rlat1=kgds(4)*1.e-3_kd + rlon1=kgds(5)*1.e-3_kd + rlat0=kgds(7)*1.e-3_kd + rlon0=kgds(8)*1.e-3_kd + + irot=mod(kgds(6)/8,2) + kscan=mod(kgds(11)/256,2) + iscan=mod(kgds(11)/128,2) + hi=(-1.)**iscan + slat1=sin(rlat1/dpr) + clat1=cos(rlat1/dpr) + slat0=sin(rlat0/dpr) + clat0=cos(rlat0/dpr) + hs=sign(1._kd,mod(rlon1-rlon0+180+3600,360._kd)-180) + clon1=cos((rlon1-rlon0)/dpr) + slatr=clat0*slat1-slat0*clat1*clon1 + clatr=sqrt(1-slatr**2) + clonr=(clat0*clat1*clon1+slat0*slat1)/clatr + rlatr=dpr*asin(slatr) + rlonr=hs*dpr*acos(clonr) + dlats=rlatr/(-(jm-1)/2) + dlons=rlonr/(-((im*2-1)-1)/2) + + if(kscan.eq.0) then + is1=(jm+1)/2 else - is1 = jm/2 - end if - - self%im = im - self%jm = jm - self%rlon0 = rlon0 - self%rlon1 = rlon1 - self%rlat1 = rlat1 - self%clat0 = clat0 - self%slat0 = slat0 - self%dlats = dlats - self%dlons = dlons - self%hi = hi - self%irot = irot - self%kscan = kscan - - end associate - - end subroutine init_grib1 + is1=jm/2 + endif + + self%im=im + self%jm=jm + self%rlon0=rlon0 + self%rlon1=rlon1 + self%rlat1=rlat1 + self%clat0=clat0 + self%slat0=slat0 + self%dlats=dlats + self%dlons=dlons + self%hi=hi + self%irot=irot + self%kscan=kscan + + endassociate + + endsubroutine init_grib1 !> Initializes a rotated equidistant cylindrical grid given a grib2_descriptor object. !> @param[inout] self The grid to initialize @@ -158,16 +158,16 @@ end subroutine init_grib1 !> !> @author Kyle Gerheiser !> @date July 2021 - subroutine init_grib2(self, g2_desc) - class(ip_rot_equid_cylind_egrid), intent(inout) :: self - type(grib2_descriptor), intent(in) :: g2_desc + subroutine init_grib2(self,g2_desc) + class(ip_rot_equid_cylind_egrid),intent(inout) :: self + type(grib2_descriptor),intent(in) :: g2_desc - integer :: iscale, iscan + integer :: iscale,iscan real(kd) :: rlat0 integer :: i_offset_odd!, i_offset_even - associate (igdtmpl => g2_desc%gdt_tmpl, igdtlen => g2_desc%gdt_len) - call earth_radius(igdtmpl, igdtlen, self%rerth, self%eccen_squared) + associate(igdtmpl=>g2_desc%gdt_tmpl,igdtlen=>g2_desc%gdt_len) + call earth_radius(igdtmpl,igdtlen,self%rerth,self%eccen_squared) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! ROUTINE ONLY WORKS FOR "E"-STAGGER GRIDS. @@ -181,38 +181,38 @@ subroutine init_grib2(self, g2_desc) ! ENDIF ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - self%im = igdtmpl(8) - self%jm = igdtmpl(9) + self%im=igdtmpl(8) + self%jm=igdtmpl(9) - self%nscan = mod(igdtmpl(16)/32, 2) - self%nscan_field_pos = 3 + self%nscan=mod(igdtmpl(16)/32,2) + self%nscan_field_pos=3 - iscale = igdtmpl(10)*igdtmpl(11) - if (iscale .eq. 0) iscale = 10**6 + iscale=igdtmpl(10)*igdtmpl(11) + if(iscale.eq.0) iscale=10**6 - self%rlon0 = float(igdtmpl(21))/float(iscale) - self%dlats = float(igdtmpl(18))/float(iscale) + self%rlon0=float(igdtmpl(21))/float(iscale) + self%dlats=float(igdtmpl(18))/float(iscale) ! THE GRIB2 CONVENTION FOR "I" RESOLUTION IS TWICE WHAT THIS ROUTINE ASSUMES. - self%dlons = float(igdtmpl(17))/float(iscale)*0.5_kd + self%dlons=float(igdtmpl(17))/float(iscale)*0.5_kd - self%irot = mod(igdtmpl(14)/8, 2) + self%irot=mod(igdtmpl(14)/8,2) - i_offset_odd = mod(igdtmpl(19)/8, 2) - self%kscan = i_offset_odd - iscan = mod(igdtmpl(19)/128, 2) + i_offset_odd=mod(igdtmpl(19)/8,2) + self%kscan=i_offset_odd + iscan=mod(igdtmpl(19)/128,2) - self%hi = (-1.)**iscan + self%hi=(-1.)**iscan - rlat0 = float(igdtmpl(20))/float(iscale) - rlat0 = rlat0+90.0_kd + rlat0=float(igdtmpl(20))/float(iscale) + rlat0=rlat0+90.0_kd - self%slat0 = sin(rlat0/dpr) - self%clat0 = cos(rlat0/dpr) + self%slat0=sin(rlat0/dpr) + self%clat0=cos(rlat0/dpr) - self%rlat1 = float(igdtmpl(12))/float(iscale) - self%rlon1 = float(igdtmpl(13))/float(iscale) - end associate - end subroutine init_grib2 + self%rlat1=float(igdtmpl(12))/float(iscale) + self%rlon1=float(igdtmpl(13))/float(iscale) + endassociate + endsubroutine init_grib2 !> Calculates Earth coordinates (iopt = 1) or grid coorindates (iopt = -1) !> for rotated equidistant cylindrical grids. @@ -261,197 +261,197 @@ end subroutine init_grib2 !> !> @author Mark Iredell, George Gayno, Kyle Gerheiser !> @date Jan 2015 - subroutine gdswzd_rot_equid_cylind_egrid(self, iopt, npts, & - fill, xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + subroutine gdswzd_rot_equid_cylind_egrid(self,iopt,npts, & + fill,xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) implicit none ! - class(ip_rot_equid_cylind_egrid), intent(in) :: self + class(ip_rot_equid_cylind_egrid),intent(in) :: self - integer, intent(in) :: iopt, npts - integer, intent(out) :: nret + integer,intent(in) :: iopt,npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(npts), rlat(npts) - real, intent(inout) :: xpts(npts), ypts(npts) - real, optional, intent(out) :: crot(npts), srot(npts) - real, optional, intent(out) :: xlon(npts), xlat(npts) - real, optional, intent(out) :: ylon(npts), ylat(npts), area(npts) + real,intent(in) :: fill + real,intent(inout) :: rlon(npts),rlat(npts) + real,intent(inout) :: xpts(npts),ypts(npts) + real,optional,intent(out) :: crot(npts),srot(npts) + real,optional,intent(out) :: xlon(npts),xlat(npts) + real,optional,intent(out) :: ylon(npts),ylat(npts),area(npts) ! - integer :: im, jm, is1, n + integer :: im,jm,is1,n integer :: kscan ! INTEGER :: I_OFFSET_ODD, I_OFFSET_EVEN ! - logical :: lrot, lmap, larea + logical :: lrot,lmap,larea ! - real(KIND=kd) :: rlat1, rlon1 + real(KIND=kd) :: rlat1,rlon1 real(KIND=kd) :: clonr - real(KIND=kd) :: rlatr, rlonr, sbd, wbd, hs, hi - real :: xmax, xmin, ymax, ymin, xptf, yptf + real(KIND=kd) :: rlatr,rlonr,sbd,wbd,hs,hi + real :: xmax,xmin,ymax,ymin,xptf,yptf ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (present(crot)) crot = fill - if (present(srot)) srot = fill - if (present(xlon)) xlon = fill - if (present(xlat)) xlat = fill - if (present(ylon)) ylon = fill - if (present(ylat)) ylat = fill - if (present(area)) area = fill - - rlon0 = self%rlon0 - irot = self%irot - im = self%im*2-1 - jm = self%jm - dlats = self%dlats - dlons = self%dlons - kscan = self%kscan - hi = self%hi - slat0 = self%slat0 - clat0 = self%clat0 - rlat1 = self%rlat1 - rlon1 = self%rlon1 - - rerth = self%rerth + if(present(crot)) crot=fill + if(present(srot)) srot=fill + if(present(xlon)) xlon=fill + if(present(xlat)) xlat=fill + if(present(ylon)) ylon=fill + if(present(ylat)) ylat=fill + if(present(area)) area=fill + + rlon0=self%rlon0 + irot=self%irot + im=self%im*2-1 + jm=self%jm + dlats=self%dlats + dlons=self%dlons + kscan=self%kscan + hi=self%hi + slat0=self%slat0 + clat0=self%clat0 + rlat1=self%rlat1 + rlon1=self%rlon1 + + rerth=self%rerth ! IS THE EARTH RADIUS DEFINED? - if (rerth .lt. 0.) then - call rot_equid_cylind_egrid_error(iopt, fill, rlat, rlon, xpts, ypts, npts) + if(rerth.lt.0.) then + call rot_equid_cylind_egrid_error(iopt,fill,rlat,rlon,xpts,ypts,npts) return - end if + endif - sbd = rlat1 - wbd = rlon1 + sbd=rlat1 + wbd=rlon1 - if (wbd .gt. 180.0) wbd = wbd-360.0 - if (kscan .eq. 0) then - is1 = (jm+1)/2 + if(wbd.gt.180.0) wbd=wbd-360.0 + if(kscan.eq.0) then + is1=(jm+1)/2 else - is1 = jm/2 - end if + is1=jm/2 + endif - xmin = 0 - xmax = im+2 - ymin = 0 - ymax = jm+1 - nret = 0 + xmin=0 + xmax=im+2 + ymin=0 + ymax=jm+1 + nret=0 - if (present(crot) .and. present(srot)) then - lrot = .true. + if(present(crot).and.present(srot)) then + lrot=.true. else - lrot = .false. - end if - if (present(xlon) .and. present(xlat) .and. present(ylon) .and. present(ylat)) then - lmap = .true. + lrot=.false. + endif + if(present(xlon).and.present(xlat).and.present(ylon).and.present(ylat)) then + lmap=.true. else - lmap = .false. - end if - if (present(area)) then - larea = .true. + lmap=.false. + endif + if(present(area)) then + larea=.true. else - larea = .false. - end if + larea=.false. + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSLATE GRID COORDINATES TO EARTH COORDINATES - if (iopt .eq. 0 .or. iopt .eq. 1) then - do n = 1, npts - xptf = ypts(n)+(xpts(n)-is1) - yptf = ypts(n)-(xpts(n)-is1)+kscan - if (xptf .ge. xmin .and. xptf .le. xmax .and. & - yptf .ge. ymin .and. yptf .le. ymax) then - hs = hi*sign(1., xptf-(im+1)/2) - select type (desc => self%descriptor) - type is (grib1_descriptor) - rlonr = (xptf-(im+1)/2)*dlons - rlatr = (yptf-(jm+1)/2)*dlats - type is (grib2_descriptor) - rlonr = (xptf-1.0_kd)*dlons+wbd - rlatr = (yptf-1.0_kd)*dlats+sbd - end select - clonr = cos(rlonr/dpr) - slatr = sin(rlatr/dpr) - clatr = cos(rlatr/dpr) - slat = clat0*slatr+slat0*clatr*clonr - if (slat .le. -1) then - clat = 0. - clon = cos(rlon0/dpr) - rlon(n) = 0 - rlat(n) = -90 - elseif (slat .ge. 1) then - clat = 0. - clon = cos(rlon0/dpr) - rlon(n) = 0 - rlat(n) = 90 + if(iopt.eq.0.or.iopt.eq.1) then + do n=1,npts + xptf=ypts(n)+(xpts(n)-is1) + yptf=ypts(n)-(xpts(n)-is1)+kscan + if(xptf.ge.xmin.and.xptf.le.xmax.and. & + yptf.ge.ymin.and.yptf.le.ymax) then + hs=hi*sign(1.,xptf-(im+1)/2) + select type(desc=>self%descriptor) + type is(grib1_descriptor) + rlonr=(xptf-(im+1)/2)*dlons + rlatr=(yptf-(jm+1)/2)*dlats + type is(grib2_descriptor) + rlonr=(xptf-1.0_kd)*dlons+wbd + rlatr=(yptf-1.0_kd)*dlats+sbd + endselect + clonr=cos(rlonr/dpr) + slatr=sin(rlatr/dpr) + clatr=cos(rlatr/dpr) + slat=clat0*slatr+slat0*clatr*clonr + if(slat.le.-1) then + clat=0. + clon=cos(rlon0/dpr) + rlon(n)=0 + rlat(n)=-90 + elseif(slat.ge.1) then + clat=0. + clon=cos(rlon0/dpr) + rlon(n)=0 + rlat(n)=90 else - clat = sqrt(1-slat**2) - clon = (clat0*clatr*clonr-slat0*slatr)/clat - clon = min(max(clon, -1._kd), 1._kd) - rlon(n) = real(mod(rlon0+hs*dpr*acos(clon)+3600, 360._kd)) - rlat(n) = real(dpr*asin(slat)) - end if - nret = nret+1 - if (lrot) call rot_equid_cylind_egrid_vect_rot(rlon(n), crot(n), srot(n)) - if (lmap) call rot_equid_cylind_egrid_map_jacob(fill, rlon(n), & - xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call rot_equid_cylind_egrid_grid_area(fill, area(n)) + clat=sqrt(1-slat**2) + clon=(clat0*clatr*clonr-slat0*slatr)/clat + clon=min(max(clon,-1._kd),1._kd) + rlon(n)=real(mod(rlon0+hs*dpr*acos(clon)+3600,360._kd)) + rlat(n)=real(dpr*asin(slat)) + endif + nret=nret+1 + if(lrot) call rot_equid_cylind_egrid_vect_rot(rlon(n),crot(n),srot(n)) + if(lmap) call rot_equid_cylind_egrid_map_jacob(fill,rlon(n), & + xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call rot_equid_cylind_egrid_grid_area(fill,area(n)) else - rlon(n) = fill - rlat(n) = fill - end if - end do + rlon(n)=fill + rlat(n)=fill + endif + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSLATE EARTH COORDINATES TO GRID COORDINATES - elseif (iopt .eq. -1) then - do n = 1, npts - if (abs(rlon(n)) .le. 360 .and. abs(rlat(n)) .le. 90) then - hs = sign(1._kd, mod(rlon(n)-rlon0+180+3600, 360._kd)-180) - clon = cos((rlon(n)-rlon0)/dpr) - slat = sin(rlat(n)/dpr) - clat = cos(rlat(n)/dpr) - slatr = clat0*slat-slat0*clat*clon - if (slatr .le. -1) then - clatr = 0. - rlonr = 0 - rlatr = -90 - elseif (slatr .ge. 1) then - clatr = 0. - rlonr = 0 - rlatr = 90 + elseif(iopt.eq.-1) then + do n=1,npts + if(abs(rlon(n)).le.360.and.abs(rlat(n)).le.90) then + hs=sign(1._kd,mod(rlon(n)-rlon0+180+3600,360._kd)-180) + clon=cos((rlon(n)-rlon0)/dpr) + slat=sin(rlat(n)/dpr) + clat=cos(rlat(n)/dpr) + slatr=clat0*slat-slat0*clat*clon + if(slatr.le.-1) then + clatr=0. + rlonr=0 + rlatr=-90 + elseif(slatr.ge.1) then + clatr=0. + rlonr=0 + rlatr=90 else - clatr = sqrt(1-slatr**2) - clonr = (clat0*clat*clon+slat0*slat)/clatr - clonr = min(max(clonr, -1._kd), 1._kd) - rlonr = hs*dpr*acos(clonr) - rlatr = dpr*asin(slatr) - end if - select type (desc => self%descriptor) - type is (grib1_descriptor) - xptf = real(((rlonr-wbd)/dlons)+1.0_kd) - yptf = real(((rlatr-sbd)/dlats)+1.0_kd) - type is (grib2_descriptor) - xptf = real((im+1)/2+rlonr/dlons) - yptf = real((jm+1)/2+rlatr/dlats) - end select - - if (xptf .ge. xmin .and. xptf .le. xmax .and. & - yptf .ge. ymin .and. yptf .le. ymax) then - xpts(n) = is1+(xptf-(yptf-kscan))/2 - ypts(n) = (xptf+(yptf-kscan))/2 - nret = nret+1 - if (lrot) call rot_equid_cylind_egrid_vect_rot(rlon(n), crot(n), srot(n)) - if (lmap) call rot_equid_cylind_egrid_map_jacob(fill, rlon(n), & - xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call rot_equid_cylind_egrid_grid_area(fill, area(n)) + clatr=sqrt(1-slatr**2) + clonr=(clat0*clat*clon+slat0*slat)/clatr + clonr=min(max(clonr,-1._kd),1._kd) + rlonr=hs*dpr*acos(clonr) + rlatr=dpr*asin(slatr) + endif + select type(desc=>self%descriptor) + type is(grib1_descriptor) + xptf=real(((rlonr-wbd)/dlons)+1.0_kd) + yptf=real(((rlatr-sbd)/dlats)+1.0_kd) + type is(grib2_descriptor) + xptf=real((im+1)/2+rlonr/dlons) + yptf=real((jm+1)/2+rlatr/dlats) + endselect + + if(xptf.ge.xmin.and.xptf.le.xmax.and. & + yptf.ge.ymin.and.yptf.le.ymax) then + xpts(n)=is1+(xptf-(yptf-kscan))/2 + ypts(n)=(xptf+(yptf-kscan))/2 + nret=nret+1 + if(lrot) call rot_equid_cylind_egrid_vect_rot(rlon(n),crot(n),srot(n)) + if(lmap) call rot_equid_cylind_egrid_map_jacob(fill,rlon(n), & + xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call rot_equid_cylind_egrid_grid_area(fill,area(n)) else - xpts(n) = fill - ypts(n) = fill - end if + xpts(n)=fill + ypts(n)=fill + endif else - xpts(n) = fill - ypts(n) = fill - end if - end do - end if - end subroutine gdswzd_rot_equid_cylind_egrid + xpts(n)=fill + ypts(n)=fill + endif + enddo + endif + endsubroutine gdswzd_rot_equid_cylind_egrid !> Error handler. !> @@ -476,24 +476,24 @@ end subroutine gdswzd_rot_equid_cylind_egrid !> @param[in] npts maximum number of coordinates !> !> @author GAYNO @date 2015-07-13 - subroutine rot_equid_cylind_egrid_error(iopt, fill, rlat, rlon, xpts, ypts, npts) + subroutine rot_equid_cylind_egrid_error(iopt,fill,rlat,rlon,xpts,ypts,npts) implicit none ! - integer, intent(in) :: iopt, npts + integer,intent(in) :: iopt,npts ! - real, intent(in) :: fill - real, intent(out) :: rlat(npts), rlon(npts) - real, intent(out) :: xpts(npts), ypts(npts) - - if (iopt .ge. 0) then - rlon = fill - rlat = fill - end if - if (iopt .le. 0) then - xpts = fill - ypts = fill - end if - end subroutine rot_equid_cylind_egrid_error + real,intent(in) :: fill + real,intent(out) :: rlat(npts),rlon(npts) + real,intent(out) :: xpts(npts),ypts(npts) + + if(iopt.ge.0) then + rlon=fill + rlat=fill + endif + if(iopt.le.0) then + xpts=fill + ypts=fill + endif + endsubroutine rot_equid_cylind_egrid_error !> Computes the vector rotation sines and !> cosines for a rotated equidistant cylindrical grid. @@ -508,29 +508,29 @@ end subroutine rot_equid_cylind_egrid_error !> !> @author George Gayno !> @date Jan 2015 - subroutine rot_equid_cylind_egrid_vect_rot(rlon, crot, srot) + subroutine rot_equid_cylind_egrid_vect_rot(rlon,crot,srot) implicit none - real, intent(in) :: rlon - real, intent(out) :: crot, srot + real,intent(in) :: rlon + real,intent(out) :: crot,srot real(KIND=kd) :: slon - if (irot .eq. 1) then - if (clatr .le. 0) then - crot = real(-sign(1._kd, slatr*slat0)) - srot = 0. + if(irot.eq.1) then + if(clatr.le.0) then + crot=real(-sign(1._kd,slatr*slat0)) + srot=0. else - slon = sin((rlon-rlon0)/dpr) - crot = real((clat0*clat+slat0*slat*clon)/clatr) - srot = real(slat0*slon/clatr) - end if + slon=sin((rlon-rlon0)/dpr) + crot=real((clat0*clat+slat0*slat*clon)/clatr) + srot=real(slat0*slon/clatr) + endif else - crot = 1. - srot = 0. - end if + crot=1. + srot=0. + endif - end subroutine rot_equid_cylind_egrid_vect_rot + endsubroutine rot_equid_cylind_egrid_vect_rot !> Computes the map jacobians for a rotated equidistant cylindrical grid. !> @@ -543,36 +543,36 @@ end subroutine rot_equid_cylind_egrid_vect_rot !> !> @author George Gayno !> @date Jan 2015 - subroutine rot_equid_cylind_egrid_map_jacob(fill, rlon, & - xlon, xlat, ylon, ylat) + subroutine rot_equid_cylind_egrid_map_jacob(fill,rlon, & + xlon,xlat,ylon,ylat) implicit none - real, intent(in) :: fill, rlon - real, intent(out) :: xlon, xlat, ylon, ylat + real,intent(in) :: fill,rlon + real,intent(out) :: xlon,xlat,ylon,ylat - real(KIND=kd) :: slon, term1, term2 - real(KIND=kd) :: xlatf, xlonf, ylatf, ylonf + real(KIND=kd) :: slon,term1,term2 + real(KIND=kd) :: xlatf,xlonf,ylatf,ylonf - if (clatr .le. 0._kd) then - xlon = fill - xlat = fill - ylon = fill - ylat = fill + if(clatr.le.0._kd) then + xlon=fill + xlat=fill + ylon=fill + ylat=fill else - slon = sin((rlon-rlon0)/dpr) - term1 = (clat0*clat+slat0*slat*clon)/clatr - term2 = slat0*slon/clatr - xlonf = term1*clat/(dlons*clatr) - xlatf = -term2/(dlons*clatr) - ylonf = term2*clat/dlats - ylatf = term1/dlats - xlon = real(xlonf-ylonf) - xlat = real(xlatf-ylatf) - ylon = real(xlonf+ylonf) - ylat = real(xlatf+ylatf) - end if - - end subroutine rot_equid_cylind_egrid_map_jacob + slon=sin((rlon-rlon0)/dpr) + term1=(clat0*clat+slat0*slat*clon)/clatr + term2=slat0*slon/clatr + xlonf=term1*clat/(dlons*clatr) + xlatf=-term2/(dlons*clatr) + ylonf=term2*clat/dlats + ylatf=term1/dlats + xlon=real(xlonf-ylonf) + xlat=real(xlatf-ylatf) + ylon=real(xlonf+ylonf) + ylat=real(xlatf+ylatf) + endif + + endsubroutine rot_equid_cylind_egrid_map_jacob !> Computes the grid box area for a rotated equidistant cylindrical grid. !> @@ -581,19 +581,19 @@ end subroutine rot_equid_cylind_egrid_map_jacob !> !> @author George Gayno !> @date Jan 2015 - subroutine rot_equid_cylind_egrid_grid_area(fill, area) + subroutine rot_equid_cylind_egrid_grid_area(fill,area) implicit none - real, intent(in) :: fill - real, intent(out) :: area + real,intent(in) :: fill + real,intent(out) :: area - if (clatr .le. 0._kd) then - area = fill + if(clatr.le.0._kd) then + area=fill else - area = real(rerth**2*clatr*dlats*dlons)*2/dpr**2 - end if + area=real(rerth**2*clatr*dlats*dlons)*2/dpr**2 + endif - end subroutine rot_equid_cylind_egrid_grid_area + endsubroutine rot_equid_cylind_egrid_grid_area -end module ip_rot_equid_cylind_egrid_mod +endmodule ip_rot_equid_cylind_egrid_mod diff --git a/src/ip_rot_equid_cylind_grid_mod.F90 b/src/ip_rot_equid_cylind_grid_mod.F90 index 24df2ace..b455883c 100644 --- a/src/ip_rot_equid_cylind_grid_mod.F90 +++ b/src/ip_rot_equid_cylind_grid_mod.F90 @@ -17,19 +17,19 @@ !> !> @author Gayno @date 2007-NOV-15 module ip_rot_equid_cylind_grid_mod - use iso_fortran_env, only: real64 + use iso_fortran_env,only:real64 use ip_grid_descriptor_mod use ip_grid_mod - use ip_constants_mod, only: dpr, pi + use ip_constants_mod,only:dpr,pi use earth_radius_mod implicit none private public :: ip_rot_equid_cylind_grid - integer, parameter :: kd = real64 !< Fortran kind for reals. + integer,parameter :: kd=real64 !< Fortran kind for reals. - type, extends(ip_grid) :: ip_rot_equid_cylind_grid + type,extends(ip_grid) :: ip_rot_equid_cylind_grid real(kd) :: clat0 !< Cosine of the latitude of the southern pole of projection. real(kd) :: dlats !< 'J'-direction grid increment. real(kd) :: dlons !< 'I'-direction grid increment. @@ -50,8 +50,8 @@ module ip_rot_equid_cylind_grid_mod procedure :: init_grib2 !> Calculates Earth coordinates (iopt = 1) or grid coorindates (iopt = -1) !> for Gaussian grids. @return N/A - procedure :: gdswzd => gdswzd_rot_equid_cylind - end type ip_rot_equid_cylind_grid + procedure :: gdswzd=>gdswzd_rot_equid_cylind + endtype ip_rot_equid_cylind_grid integer :: irot !< Local copy of irot. real(KIND=kd) :: rerth !< Radius of the Earth. @@ -70,64 +70,64 @@ module ip_rot_equid_cylind_grid_mod !> @param[in] g1_desc A grib1_descriptor !> !> @author Gayno @date 2007-NOV-15 - subroutine init_grib1(self, g1_desc) - class(ip_rot_equid_cylind_grid), intent(inout) :: self - type(grib1_descriptor), intent(in) :: g1_desc - - real(kd) :: rlat1, rlon1, rlat0, rlat2, rlon2, nbd, ebd - real(kd) :: hs, hs2, slat1, slat2, slatr, clon1, clon2, clat1, clat2, clatr, clonr, rlonr, rlatr - - associate (kgds => g1_desc%gds) - self%rerth = 6.3712e6_kd - self%eccen_squared = 0d0 - - rlat1 = kgds(4)*1.e-3_kd - rlon1 = kgds(5)*1.e-3_kd - rlat0 = kgds(7)*1.e-3_kd - self%rlon0 = kgds(8)*1.e-3_kd - rlat2 = kgds(12)*1.e-3_kd - rlon2 = kgds(13)*1.e-3_kd - - self%irot = mod(kgds(6)/8, 2) - self%im = kgds(2) - self%jm = kgds(3) - - slat1 = sin(rlat1/dpr) - clat1 = cos(rlat1/dpr) - self%slat0 = sin(rlat0/dpr) - self%clat0 = cos(rlat0/dpr) - - hs = sign(1._kd, mod(rlon1-self%rlon0+180+3600, 360._kd)-180) - clon1 = cos((rlon1-self%rlon0)/dpr) - slatr = self%clat0*slat1-self%slat0*clat1*clon1 - clatr = sqrt(1-slatr**2) - clonr = (self%clat0*clat1*clon1+self%slat0*slat1)/clatr - rlatr = dpr*asin(slatr) - rlonr = hs*dpr*acos(clonr) - - self%wbd = rlonr - self%sbd = rlatr - slat2 = sin(rlat2/dpr) - clat2 = cos(rlat2/dpr) - hs2 = sign(1._kd, mod(rlon2-self%rlon0+180+3600, 360._kd)-180) - clon2 = cos((rlon2-self%rlon0)/dpr) - slatr = self%clat0*slat2-self%slat0*clat2*clon2 - clatr = sqrt(1-slatr**2) - clonr = (self%clat0*clat2*clon2+self%slat0*slat2)/clatr - nbd = dpr*asin(slatr) - ebd = hs2*dpr*acos(clonr) - self%dlats = (nbd-self%sbd)/float(self%jm-1) - self%dlons = (ebd-self%wbd)/float(self%im-1) - - self%iwrap = 0 - self%jwrap1 = 0 - self%jwrap2 = 0 - self%nscan = mod(kgds(11)/32, 2) - self%nscan_field_pos = self%nscan - self%kscan = 0 - end associate - - end subroutine init_grib1 + subroutine init_grib1(self,g1_desc) + class(ip_rot_equid_cylind_grid),intent(inout) :: self + type(grib1_descriptor),intent(in) :: g1_desc + + real(kd) :: rlat1,rlon1,rlat0,rlat2,rlon2,nbd,ebd + real(kd) :: hs,hs2,slat1,slat2,slatr,clon1,clon2,clat1,clat2,clatr,clonr,rlonr,rlatr + + associate(kgds=>g1_desc%gds) + self%rerth=6.3712e6_kd + self%eccen_squared=0d0 + + rlat1=kgds(4)*1.e-3_kd + rlon1=kgds(5)*1.e-3_kd + rlat0=kgds(7)*1.e-3_kd + self%rlon0=kgds(8)*1.e-3_kd + rlat2=kgds(12)*1.e-3_kd + rlon2=kgds(13)*1.e-3_kd + + self%irot=mod(kgds(6)/8,2) + self%im=kgds(2) + self%jm=kgds(3) + + slat1=sin(rlat1/dpr) + clat1=cos(rlat1/dpr) + self%slat0=sin(rlat0/dpr) + self%clat0=cos(rlat0/dpr) + + hs=sign(1._kd,mod(rlon1-self%rlon0+180+3600,360._kd)-180) + clon1=cos((rlon1-self%rlon0)/dpr) + slatr=self%clat0*slat1-self%slat0*clat1*clon1 + clatr=sqrt(1-slatr**2) + clonr=(self%clat0*clat1*clon1+self%slat0*slat1)/clatr + rlatr=dpr*asin(slatr) + rlonr=hs*dpr*acos(clonr) + + self%wbd=rlonr + self%sbd=rlatr + slat2=sin(rlat2/dpr) + clat2=cos(rlat2/dpr) + hs2=sign(1._kd,mod(rlon2-self%rlon0+180+3600,360._kd)-180) + clon2=cos((rlon2-self%rlon0)/dpr) + slatr=self%clat0*slat2-self%slat0*clat2*clon2 + clatr=sqrt(1-slatr**2) + clonr=(self%clat0*clat2*clon2+self%slat0*slat2)/clatr + nbd=dpr*asin(slatr) + ebd=hs2*dpr*acos(clonr) + self%dlats=(nbd-self%sbd)/float(self%jm-1) + self%dlons=(ebd-self%wbd)/float(self%im-1) + + self%iwrap=0 + self%jwrap1=0 + self%jwrap2=0 + self%nscan=mod(kgds(11)/32,2) + self%nscan_field_pos=self%nscan + self%kscan=0 + endassociate + + endsubroutine init_grib1 !> Initializes a Rotated equidistant cylindrical grid given a !> grib2_descriptor object. @@ -136,63 +136,63 @@ end subroutine init_grib1 !> @param[in] g2_desc A grib2_descriptor !> !> @author Gayno @date 2007-NOV-15 - subroutine init_grib2(self, g2_desc) - class(ip_rot_equid_cylind_grid), intent(inout) :: self - type(grib2_descriptor), intent(in) :: g2_desc + subroutine init_grib2(self,g2_desc) + class(ip_rot_equid_cylind_grid),intent(inout) :: self + type(grib2_descriptor),intent(in) :: g2_desc - real(kd) :: rlat1, rlon1, rlat0, rlat2, rlon2, nbd, ebd + real(kd) :: rlat1,rlon1,rlat0,rlat2,rlon2,nbd,ebd integer :: iscale - integer :: i_offset_odd, i_offset_even, j_offset + integer :: i_offset_odd,i_offset_even,j_offset - associate (igdtmpl => g2_desc%gdt_tmpl, igdtlen => g2_desc%gdt_len) + associate(igdtmpl=>g2_desc%gdt_tmpl,igdtlen=>g2_desc%gdt_len) - call earth_radius(igdtmpl, igdtlen, self%rerth, self%eccen_squared) + call earth_radius(igdtmpl,igdtlen,self%rerth,self%eccen_squared) - i_offset_odd = mod(igdtmpl(19)/8, 2) - i_offset_even = mod(igdtmpl(19)/4, 2) - j_offset = mod(igdtmpl(19)/2, 2) + i_offset_odd=mod(igdtmpl(19)/8,2) + i_offset_even=mod(igdtmpl(19)/4,2) + j_offset=mod(igdtmpl(19)/2,2) - iscale = igdtmpl(10)*igdtmpl(11) - if (iscale .eq. 0) iscale = 10**6 + iscale=igdtmpl(10)*igdtmpl(11) + if(iscale.eq.0) iscale=10**6 - rlat1 = float(igdtmpl(12))/float(iscale) - rlon1 = float(igdtmpl(13))/float(iscale) - rlat0 = float(igdtmpl(20))/float(iscale) - rlat0 = rlat0+90.0_kd + rlat1=float(igdtmpl(12))/float(iscale) + rlon1=float(igdtmpl(13))/float(iscale) + rlat0=float(igdtmpl(20))/float(iscale) + rlat0=rlat0+90.0_kd - self%rlon0 = float(igdtmpl(21))/float(iscale) + self%rlon0=float(igdtmpl(21))/float(iscale) - rlat2 = float(igdtmpl(15))/float(iscale) - rlon2 = float(igdtmpl(16))/float(iscale) + rlat2=float(igdtmpl(15))/float(iscale) + rlon2=float(igdtmpl(16))/float(iscale) - self%irot = mod(igdtmpl(14)/8, 2) - self%im = igdtmpl(8) - self%jm = igdtmpl(9) + self%irot=mod(igdtmpl(14)/8,2) + self%im=igdtmpl(8) + self%jm=igdtmpl(9) - self%slat0 = sin(rlat0/dpr) - self%clat0 = cos(rlat0/dpr) + self%slat0=sin(rlat0/dpr) + self%clat0=cos(rlat0/dpr) - self%wbd = rlon1 - if (self%wbd .gt. 180.0) self%wbd = self%wbd-360.0 - self%sbd = rlat1 + self%wbd=rlon1 + if(self%wbd.gt.180.0) self%wbd=self%wbd-360.0 + self%sbd=rlat1 - nbd = rlat2 - ebd = rlon2 + nbd=rlat2 + ebd=rlon2 - self%dlats = (nbd-self%sbd)/float(self%jm-1) - self%dlons = (ebd-self%wbd)/float(self%im-1) + self%dlats=(nbd-self%sbd)/float(self%jm-1) + self%dlons=(ebd-self%wbd)/float(self%im-1) - if (i_offset_odd .eq. 1) self%wbd = self%wbd+(0.5_kd*self%dlons) - if (j_offset .eq. 1) self%sbd = self%sbd+(0.5_kd*self%dlats) + if(i_offset_odd.eq.1) self%wbd=self%wbd+(0.5_kd*self%dlons) + if(j_offset.eq.1) self%sbd=self%sbd+(0.5_kd*self%dlats) - self%iwrap = 0 - self%jwrap1 = 0 - self%jwrap2 = 0 - self%kscan = 0 - self%nscan = mod(igdtmpl(19)/32, 2) - self%nscan_field_pos = self%nscan - end associate - end subroutine init_grib2 + self%iwrap=0 + self%jwrap1=0 + self%jwrap2=0 + self%kscan=0 + self%nscan=mod(igdtmpl(19)/32,2) + self%nscan_field_pos=self%nscan + endassociate + endsubroutine init_grib2 !> GDS wizard for rotated equidistant cylindrical. !> @@ -253,40 +253,40 @@ end subroutine init_grib2 !> @param[out] area real, optional (npts) area weights in m**2 !> !> @author Gayno @date 2007-NOV-15 - subroutine gdswzd_rot_equid_cylind(self, iopt, npts, & - fill, xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) + subroutine gdswzd_rot_equid_cylind(self,iopt,npts, & + fill,xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) implicit none - class(ip_rot_equid_cylind_grid), intent(in) :: self - integer, intent(in) :: iopt, npts - integer, intent(out) :: nret + class(ip_rot_equid_cylind_grid),intent(in) :: self + integer,intent(in) :: iopt,npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(npts), rlat(npts) - real, intent(inout) :: xpts(npts), ypts(npts) - real, optional, intent(out) :: crot(npts), srot(npts) - real, optional, intent(out) :: xlon(npts), xlat(npts) - real, optional, intent(out) :: ylon(npts), ylat(npts), area(npts) + real,intent(in) :: fill + real,intent(inout) :: rlon(npts),rlat(npts) + real,intent(inout) :: xpts(npts),ypts(npts) + real,optional,intent(out) :: crot(npts),srot(npts) + real,optional,intent(out) :: xlon(npts),xlat(npts) + real,optional,intent(out) :: ylon(npts),ylat(npts),area(npts) ! - integer :: im, jm, n + integer :: im,jm,n ! - logical :: lrot, lmap, larea + logical :: lrot,lmap,larea ! real(KIND=kd) :: hs - real(KIND=kd) :: clonr, clatr, slatr - real(KIND=kd) :: clat, slat, clon - real(KIND=kd) :: rlatr, rlonr - real(KIND=kd) :: wbd, sbd - real :: xmin, xmax, ymin, ymax + real(KIND=kd) :: clonr,clatr,slatr + real(KIND=kd) :: clat,slat,clon + real(KIND=kd) :: rlatr,rlonr + real(KIND=kd) :: wbd,sbd + real :: xmin,xmax,ymin,ymax ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (present(crot)) crot = fill - if (present(srot)) srot = fill - if (present(xlon)) xlon = fill - if (present(xlat)) xlat = fill - if (present(ylon)) ylon = fill - if (present(ylat)) ylat = fill - if (present(area)) area = fill + if(present(crot)) crot=fill + if(present(srot)) srot=fill + if(present(xlon)) xlon=fill + if(present(xlat)) xlat=fill + if(present(ylon)) ylon=fill + if(present(ylat)) ylat=fill + if(present(area)) area=fill ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! IS THE EARTH RADIUS DEFINED? ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -300,146 +300,146 @@ subroutine gdswzd_rot_equid_cylind(self, iopt, npts, & ! ENDIF ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - rlon0 = self%rlon0 - irot = self%irot + rlon0=self%rlon0 + irot=self%irot - im = self%im - jm = self%jm + im=self%im + jm=self%jm - slat0 = self%slat0 - clat0 = self%clat0 + slat0=self%slat0 + clat0=self%clat0 - wbd = self%wbd - sbd = self%sbd + wbd=self%wbd + sbd=self%sbd - dlats = self%dlats - dlons = self%dlons + dlats=self%dlats + dlons=self%dlons - xmin = 0 - xmax = im+1 - ymin = 0 - ymax = jm+1 - nret = 0 + xmin=0 + xmax=im+1 + ymin=0 + ymax=jm+1 + nret=0 - rerth = self%rerth - if (rerth .lt. 0.) then - call rot_equid_cylind_error(iopt, fill, rlat, rlon, xpts, ypts, npts) + rerth=self%rerth + if(rerth.lt.0.) then + call rot_equid_cylind_error(iopt,fill,rlat,rlon,xpts,ypts,npts) return - end if + endif - if (present(crot) .and. present(srot)) then - lrot = .true. + if(present(crot).and.present(srot)) then + lrot=.true. else - lrot = .false. - end if - if (present(xlon) .and. present(xlat) .and. present(ylon) .and. present(ylat)) then - lmap = .true. + lrot=.false. + endif + if(present(xlon).and.present(xlat).and.present(ylon).and.present(ylat)) then + lmap=.true. else - lmap = .false. - end if - if (present(area)) then - larea = .true. + lmap=.false. + endif + if(present(area)) then + larea=.true. else - larea = .false. - end if + larea=.false. + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSLATE GRID COORDINATES TO EARTH COORDINATES - if (iopt .eq. 0 .or. iopt .eq. 1) then - !$omp parallel do private(n, rlonr, rlatr, hs, clonr, slatr, clatr, slat, clat, clon) & + if(iopt.eq.0.or.iopt.eq.1) then + !$omp parallel do private(n,rlonr,rlatr,hs,clonr,slatr,clatr,slat,clat,clon) & !$omp&reduction(+:nret) schedule(static) - do n = 1, npts - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - rlonr = wbd+(xpts(n)-1._kd)*dlons - rlatr = sbd+(ypts(n)-1._kd)*dlats - if (rlonr .le. 0._kd) then - hs = -1.0_kd + do n=1,npts + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + rlonr=wbd+(xpts(n)-1._kd)*dlons + rlatr=sbd+(ypts(n)-1._kd)*dlats + if(rlonr.le.0._kd) then + hs=-1.0_kd else - hs = 1.0_kd - end if - clonr = cos(rlonr/dpr) - slatr = sin(rlatr/dpr) - clatr = cos(rlatr/dpr) - slat = clat0*slatr+slat0*clatr*clonr - if (slat .le. -1) then - clat = 0. - clon = cos(rlon0/dpr) - rlon(n) = 0. - rlat(n) = -90. - elseif (slat .ge. 1) then - clat = 0. - clon = cos(rlon0/dpr) - rlon(n) = 0. - rlat(n) = 90. + hs=1.0_kd + endif + clonr=cos(rlonr/dpr) + slatr=sin(rlatr/dpr) + clatr=cos(rlatr/dpr) + slat=clat0*slatr+slat0*clatr*clonr + if(slat.le.-1) then + clat=0. + clon=cos(rlon0/dpr) + rlon(n)=0. + rlat(n)=-90. + elseif(slat.ge.1) then + clat=0. + clon=cos(rlon0/dpr) + rlon(n)=0. + rlat(n)=90. else - clat = sqrt(1-slat**2) - clon = (clat0*clatr*clonr-slat0*slatr)/clat - clon = min(max(clon, -1._kd), 1._kd) - rlon(n) = real(mod(rlon0+hs*dpr*acos(clon)+3600, 360._kd)) - rlat(n) = real(dpr*asin(slat)) - end if - nret = nret+1 - if (lrot) call rot_equid_cylind_vect_rot(rlon(n), clatr, slatr, & - clat, slat, clon, crot(n), srot(n)) - if (lmap) call rot_equid_cylind_map_jacob(fill, rlon(n), clatr, & - clat, slat, clon, xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call rot_equid_cylind_grid_area(clatr, fill, area(n)) + clat=sqrt(1-slat**2) + clon=(clat0*clatr*clonr-slat0*slatr)/clat + clon=min(max(clon,-1._kd),1._kd) + rlon(n)=real(mod(rlon0+hs*dpr*acos(clon)+3600,360._kd)) + rlat(n)=real(dpr*asin(slat)) + endif + nret=nret+1 + if(lrot) call rot_equid_cylind_vect_rot(rlon(n),clatr,slatr, & + clat,slat,clon,crot(n),srot(n)) + if(lmap) call rot_equid_cylind_map_jacob(fill,rlon(n),clatr, & + clat,slat,clon,xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call rot_equid_cylind_grid_area(clatr,fill,area(n)) else - rlon(n) = fill - rlat(n) = fill - end if - end do + rlon(n)=fill + rlat(n)=fill + endif + enddo !$omp end parallel do ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSLATE EARTH COORDINATES TO GRID COORDINATES - elseif (iopt .eq. -1) then - !$omp parallel do private(n, hs, clon, slat, clat, slatr, clatr, clonr, rlonr, rlatr) & + elseif(iopt.eq.-1) then + !$omp parallel do private(n,hs,clon,slat,clat,slatr,clatr,clonr,rlonr,rlatr) & !$omp&reduction(+:nret) schedule(static) - do n = 1, npts - if (abs(rlon(n)) .le. 360 .and. abs(rlat(n)) .le. 90) then - hs = sign(1._kd, mod(rlon(n)-rlon0+180+3600, 360._kd)-180) - clon = cos((rlon(n)-rlon0)/dpr) - slat = sin(rlat(n)/dpr) - clat = cos(rlat(n)/dpr) - slatr = clat0*slat-slat0*clat*clon - if (slatr .le. -1) then - clatr = 0._kd - rlonr = 0. - rlatr = -90. - elseif (slatr .ge. 1) then - clatr = 0._kd - rlonr = 0. - rlatr = 90. + do n=1,npts + if(abs(rlon(n)).le.360.and.abs(rlat(n)).le.90) then + hs=sign(1._kd,mod(rlon(n)-rlon0+180+3600,360._kd)-180) + clon=cos((rlon(n)-rlon0)/dpr) + slat=sin(rlat(n)/dpr) + clat=cos(rlat(n)/dpr) + slatr=clat0*slat-slat0*clat*clon + if(slatr.le.-1) then + clatr=0._kd + rlonr=0. + rlatr=-90. + elseif(slatr.ge.1) then + clatr=0._kd + rlonr=0. + rlatr=90. else - clatr = sqrt(1-slatr**2) - clonr = (clat0*clat*clon+slat0*slat)/clatr - clonr = min(max(clonr, -1._kd), 1._kd) - rlonr = hs*dpr*acos(clonr) - rlatr = dpr*asin(slatr) - end if - xpts(n) = real((rlonr-wbd)/dlons+1._kd) - ypts(n) = real((rlatr-sbd)/dlats+1._kd) - if (xpts(n) .ge. xmin .and. xpts(n) .le. xmax .and. & - ypts(n) .ge. ymin .and. ypts(n) .le. ymax) then - nret = nret+1 - if (lrot) call rot_equid_cylind_vect_rot(rlon(n), clatr, slatr, & - clat, slat, clon, crot(n), srot(n)) - if (lmap) call rot_equid_cylind_map_jacob(fill, rlon(n), clatr, & - clat, slat, clon, xlon(n), xlat(n), ylon(n), ylat(n)) - if (larea) call rot_equid_cylind_grid_area(clatr, fill, area(n)) + clatr=sqrt(1-slatr**2) + clonr=(clat0*clat*clon+slat0*slat)/clatr + clonr=min(max(clonr,-1._kd),1._kd) + rlonr=hs*dpr*acos(clonr) + rlatr=dpr*asin(slatr) + endif + xpts(n)=real((rlonr-wbd)/dlons+1._kd) + ypts(n)=real((rlatr-sbd)/dlats+1._kd) + if(xpts(n).ge.xmin.and.xpts(n).le.xmax.and. & + ypts(n).ge.ymin.and.ypts(n).le.ymax) then + nret=nret+1 + if(lrot) call rot_equid_cylind_vect_rot(rlon(n),clatr,slatr, & + clat,slat,clon,crot(n),srot(n)) + if(lmap) call rot_equid_cylind_map_jacob(fill,rlon(n),clatr, & + clat,slat,clon,xlon(n),xlat(n),ylon(n),ylat(n)) + if(larea) call rot_equid_cylind_grid_area(clatr,fill,area(n)) else - xpts(n) = fill - ypts(n) = fill - end if + xpts(n)=fill + ypts(n)=fill + endif else - xpts(n) = fill - ypts(n) = fill - end if - end do + xpts(n)=fill + ypts(n)=fill + endif + enddo !$omp end parallel do - end if + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine gdswzd_rot_equid_cylind + endsubroutine gdswzd_rot_equid_cylind !> Error handler. !> @@ -458,25 +458,25 @@ end subroutine gdswzd_rot_equid_cylind !> @param[in] npts integer maximum number of coordinates !> !> @author Gayno @date 2015-07-13 - subroutine rot_equid_cylind_error(iopt, fill, rlat, rlon, xpts, ypts, npts) + subroutine rot_equid_cylind_error(iopt,fill,rlat,rlon,xpts,ypts,npts) implicit none ! - integer, intent(in) :: iopt, npts + integer,intent(in) :: iopt,npts ! - real, intent(in) :: fill - real, intent(out) :: rlat(npts), rlon(npts) - real, intent(out) :: xpts(npts), ypts(npts) + real,intent(in) :: fill + real,intent(out) :: rlat(npts),rlon(npts) + real,intent(out) :: xpts(npts),ypts(npts) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (iopt .ge. 0) then - rlon = fill - rlat = fill - end if - if (iopt .le. 0) then - xpts = fill - ypts = fill - end if + if(iopt.ge.0) then + rlon=fill + rlat=fill + endif + if(iopt.le.0) then + xpts=fill + ypts=fill + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine rot_equid_cylind_error + endsubroutine rot_equid_cylind_error !> Vector rotation fields for rotated equidistant cylindrical grids - !> non "e" stagger. @@ -503,31 +503,31 @@ end subroutine rot_equid_cylind_error !> vgrid=srot*uearth+crot*vearth) !> !> @author Gayno @date 2015-01-21 - subroutine rot_equid_cylind_vect_rot(rlon, clatr, slatr, clat, slat, & - clon, crot, srot) + subroutine rot_equid_cylind_vect_rot(rlon,clatr,slatr,clat,slat, & + clon,crot,srot) implicit none - real(KIND=kd), intent(in) :: clat, clatr, clon, slat, slatr - real, intent(in) :: rlon - real, intent(out) :: crot, srot + real(KIND=kd),intent(in) :: clat,clatr,clon,slat,slatr + real,intent(in) :: rlon + real,intent(out) :: crot,srot real(KIND=kd) :: slon - if (irot .eq. 1) then - if (clatr .le. 0._kd) then - crot = real(-sign(1._kd, slatr*slat0)) - srot = 0. + if(irot.eq.1) then + if(clatr.le.0._kd) then + crot=real(-sign(1._kd,slatr*slat0)) + srot=0. else - slon = sin((rlon-rlon0)/dpr) - crot = real((clat0*clat+slat0*slat*clon)/clatr) - srot = real(slat0*slon/clatr) - end if + slon=sin((rlon-rlon0)/dpr) + crot=real((clat0*clat+slat0*slat*clon)/clatr) + srot=real(slat0*slon/clatr) + endif else - crot = 1. - srot = 0. - end if + crot=1. + srot=0. + endif - end subroutine rot_equid_cylind_vect_rot + endsubroutine rot_equid_cylind_vect_rot !> Map jacobians for rotated equidistant cylindrical !> grids - non "e" stagger. @@ -554,32 +554,32 @@ end subroutine rot_equid_cylind_vect_rot !> @param[out] ylat dy/dlat in 1/degrees (real) !> !> @author Gayno @date 2015-01-21 - subroutine rot_equid_cylind_map_jacob(fill, rlon, clatr, clat, & - slat, clon, xlon, xlat, ylon, ylat) + subroutine rot_equid_cylind_map_jacob(fill,rlon,clatr,clat, & + slat,clon,xlon,xlat,ylon,ylat) implicit none - real(KIND=kd), intent(in) :: clatr, clat, slat, clon - real, intent(in) :: fill, rlon - real, intent(out) :: xlon, xlat, ylon, ylat + real(KIND=kd),intent(in) :: clatr,clat,slat,clon + real,intent(in) :: fill,rlon + real,intent(out) :: xlon,xlat,ylon,ylat - real(KIND=kd) :: slon, term1, term2 + real(KIND=kd) :: slon,term1,term2 - if (clatr .le. 0._kd) then - xlon = fill - xlat = fill - ylon = fill - ylat = fill + if(clatr.le.0._kd) then + xlon=fill + xlat=fill + ylon=fill + ylat=fill else - slon = sin((rlon-rlon0)/dpr) - term1 = (clat0*clat+slat0*slat*clon)/clatr - term2 = slat0*slon/clatr - xlon = real(term1*clat/(dlons*clatr)) - xlat = real(-term2/(dlons*clatr)) - ylon = real(term2*clat/dlats) - ylat = real(term1/dlats) - end if + slon=sin((rlon-rlon0)/dpr) + term1=(clat0*clat+slat0*slat*clon)/clatr + term2=slat0*slon/clatr + xlon=real(term1*clat/(dlons*clatr)) + xlat=real(-term2/(dlons*clatr)) + ylon=real(term2*clat/dlats) + ylat=real(term1/dlats) + endif - end subroutine rot_equid_cylind_map_jacob + endsubroutine rot_equid_cylind_map_jacob !> Grid box area for rotated equidistant cylindrical grids - non "e" !> stagger. @@ -599,20 +599,20 @@ end subroutine rot_equid_cylind_map_jacob !> @param[out] area area weights in m**2 (real) !> !> @author Gayno @date 2015-01-21 - subroutine rot_equid_cylind_grid_area(clatr, fill, area) + subroutine rot_equid_cylind_grid_area(clatr,fill,area) implicit none - real(KIND=kd), intent(in) :: clatr - real, intent(in) :: fill - real, intent(out) :: area + real(KIND=kd),intent(in) :: clatr + real,intent(in) :: fill + real,intent(out) :: area - if (clatr .le. 0._kd) then - area = fill + if(clatr.le.0._kd) then + area=fill else - area = real(2._kd*(rerth**2)*clatr*(dlons/dpr)*sin(0.5_kd*dlats/dpr)) - end if + area=real(2._kd*(rerth**2)*clatr*(dlons/dpr)*sin(0.5_kd*dlats/dpr)) + endif - end subroutine rot_equid_cylind_grid_area + endsubroutine rot_equid_cylind_grid_area -end module ip_rot_equid_cylind_grid_mod +endmodule ip_rot_equid_cylind_grid_mod diff --git a/src/ip_station_points_grid_mod.F90 b/src/ip_station_points_grid_mod.F90 index 2c05623a..69dd1e3a 100644 --- a/src/ip_station_points_grid_mod.F90 +++ b/src/ip_station_points_grid_mod.F90 @@ -15,7 +15,7 @@ module ip_station_points_grid_mod private public :: ip_station_points_grid - type, extends(ip_grid) :: ip_station_points_grid + type,extends(ip_grid) :: ip_station_points_grid contains !> Initializes a gaussian grid given a grib1_descriptor object. @return N/A procedure :: init_grib1 @@ -23,8 +23,8 @@ module ip_station_points_grid_mod procedure :: init_grib2 !> Calculates Earth coordinates (iopt = 1) or grid coorindates (iopt = -1) !> for IP Station Point grids. @return N/A - procedure :: gdswzd => gdswzd_station_points - end type ip_station_points_grid + procedure :: gdswzd=>gdswzd_station_points + endtype ip_station_points_grid contains @@ -34,10 +34,10 @@ module ip_station_points_grid_mod !> @param[in] g1_desc A grib1_descriptor !> !> @author Iredell @date 96-04-10 - subroutine init_grib1(self, g1_desc) - class(ip_station_points_grid), intent(inout) :: self - type(grib1_descriptor), intent(in) :: g1_desc - end subroutine init_grib1 + subroutine init_grib1(self,g1_desc) + class(ip_station_points_grid),intent(inout) :: self + type(grib1_descriptor),intent(in) :: g1_desc + endsubroutine init_grib1 !> Initializes an IP Station grid given a grib2_descriptor object. !> @@ -45,10 +45,10 @@ end subroutine init_grib1 !> @param[in] g2_desc A grib2_descriptor !> !> @author Iredell @date 96-04-10 - subroutine init_grib2(self, g2_desc) - class(ip_station_points_grid), intent(inout) :: self - type(grib2_descriptor), intent(in) :: g2_desc - end subroutine init_grib2 + subroutine init_grib2(self,g2_desc) + class(ip_station_points_grid),intent(inout) :: self + type(grib2_descriptor),intent(in) :: g2_desc + endsubroutine init_grib2 !> Interpolate gridded data to a series of station points. !> @@ -72,23 +72,23 @@ end subroutine init_grib2 !> !> @author Kyle Gerheiser @date 7/21/21 !> @author Eric Engle @date 5/4/23 - subroutine gdswzd_station_points(self, iopt, npts, & - fill, xpts, ypts, rlon, rlat, nret, & - crot, srot, xlon, xlat, ylon, ylat, area) - class(ip_station_points_grid), intent(in) :: self - integer, intent(in) :: iopt, npts - integer, intent(out) :: nret + subroutine gdswzd_station_points(self,iopt,npts, & + fill,xpts,ypts,rlon,rlat,nret, & + crot,srot,xlon,xlat,ylon,ylat,area) + class(ip_station_points_grid),intent(in) :: self + integer,intent(in) :: iopt,npts + integer,intent(out) :: nret ! - real, intent(in) :: fill - real, intent(inout) :: rlon(npts), rlat(npts) - real, intent(inout) :: xpts(npts), ypts(npts) - real, optional, intent(out) :: crot(npts), srot(npts) - real, optional, intent(out) :: xlon(npts), xlat(npts) - real, optional, intent(out) :: ylon(npts), ylat(npts), area(npts) + real,intent(in) :: fill + real,intent(inout) :: rlon(npts),rlat(npts) + real,intent(inout) :: xpts(npts),ypts(npts) + real,optional,intent(out) :: crot(npts),srot(npts) + real,optional,intent(out) :: xlon(npts),xlat(npts) + real,optional,intent(out) :: ylon(npts),ylat(npts),area(npts) ! This is all that needs to be done for GDSWZD for station points. - nret = npts + nret=npts - end subroutine gdswzd_station_points + endsubroutine gdswzd_station_points -end module ip_station_points_grid_mod +endmodule ip_station_points_grid_mod diff --git a/src/ipolates.F90 b/src/ipolates.F90 index fccefb6a..605e1b82 100644 --- a/src/ipolates.F90 +++ b/src/ipolates.F90 @@ -12,20 +12,20 @@ module ipolates_mod use ip_interpolators_mod use ip_grid_descriptor_mod - use ip_grid_factory_mod, only: init_grid + use ip_grid_factory_mod,only:init_grid use ip_interpolators_mod use ip_grid_mod implicit none private - public :: ipolates, ipolates_grib2, ipolates_grib1_single_field, ipolates_grib1, ipolates_grib2_single_field + public :: ipolates,ipolates_grib2,ipolates_grib1_single_field,ipolates_grib1,ipolates_grib2_single_field interface ipolates module procedure ipolates_grib1 module procedure ipolates_grib1_single_field module procedure ipolates_grib2 module procedure ipolates_grib2_single_field - end interface ipolates + endinterface ipolates contains @@ -60,41 +60,41 @@ module ipolates_mod !! - 4x Invalid spectral method parameters. !! !! @author Mark Iredell, Kyle Gerheiser - subroutine ipolates_grid(ip, ipopt, grid_in, grid_out, mi, mo, km,& - & ibi, li, gi, no, rlat, rlon, ibo, lo, go, iret) - class(ip_grid), intent(in) :: grid_in, grid_out - integer, intent(in) :: ip, ipopt(20), km, mi, mo - integer, intent(in) :: ibi(km) - integer, intent(inout) :: no - integer, intent(out) :: iret, ibo(km) + subroutine ipolates_grid(ip,ipopt,grid_in,grid_out,mi,mo,km,& + & ibi,li,gi,no,rlat,rlon,ibo,lo,go,iret) + class(ip_grid),intent(in) :: grid_in,grid_out + integer,intent(in) :: ip,ipopt(20),km,mi,mo + integer,intent(in) :: ibi(km) + integer,intent(inout) :: no + integer,intent(out) :: iret,ibo(km) ! - logical*1, intent(in) :: li(mi, km) - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(in) :: li(mi,km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: gi(mi, km) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: go(mo, km) + real,intent(in) :: gi(mi,km) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: go(mo,km) ! - select case (ip) - case (bilinear_interp_id) - call interpolate_bilinear(ipopt, grid_in, grid_out, mi, mo, km, ibi& - &, li, gi, no, rlat, rlon, ibo, lo, go, iret) - case (bicubic_interp_id) - call interpolate_bicubic(ipopt, grid_in, grid_out, mi, mo, km, ibi& - &, li, gi, no, rlat, rlon, ibo, lo, go, iret) - case (neighbor_interp_id) - call interpolate_neighbor(ipopt, grid_in, grid_out, mi, mo, km, ibi& - &, li, gi, no, rlat, rlon, ibo, lo, go, iret) - case (budget_interp_id) - call interpolate_budget(ipopt, grid_in, grid_out, mi, mo, km, ibi, li& - &, gi, no, rlat, rlon, ibo, lo, go, iret) - case (spectral_interp_id) - call interpolate_spectral(ipopt, grid_in, grid_out, mi, mo, km, ibi& - &, gi, no, rlat, rlon, ibo, lo, go, iret) - case (neighbor_budget_interp_id) - call interpolate_neighbor_budget(ipopt, grid_in, grid_out, mi, mo& - &, km, ibi, li, gi, no, rlat, rlon, ibo, lo, go, iret) + select case(ip) + case(bilinear_interp_id) + call interpolate_bilinear(ipopt,grid_in,grid_out,mi,mo,km,ibi& + &,li,gi,no,rlat,rlon,ibo,lo,go,iret) + case(bicubic_interp_id) + call interpolate_bicubic(ipopt,grid_in,grid_out,mi,mo,km,ibi& + &,li,gi,no,rlat,rlon,ibo,lo,go,iret) + case(neighbor_interp_id) + call interpolate_neighbor(ipopt,grid_in,grid_out,mi,mo,km,ibi& + &,li,gi,no,rlat,rlon,ibo,lo,go,iret) + case(budget_interp_id) + call interpolate_budget(ipopt,grid_in,grid_out,mi,mo,km,ibi,li& + &,gi,no,rlat,rlon,ibo,lo,go,iret) + case(spectral_interp_id) + call interpolate_spectral(ipopt,grid_in,grid_out,mi,mo,km,ibi& + &,gi,no,rlat,rlon,ibo,lo,go,iret) + case(neighbor_budget_interp_id) + call interpolate_neighbor_budget(ipopt,grid_in,grid_out,mi,mo& + &,km,ibi,li,gi,no,rlat,rlon,ibo,lo,go,iret) case default ! IF(KGDSO(1).GE.0) NO=0 ! DO K=1,KM @@ -104,12 +104,12 @@ subroutine ipolates_grid(ip, ipopt, grid_in, grid_out, mi, mo, km,& ! GO(N,K)=0. ! ENDDO ! ENDDO - iret = 1 - print *, "Unrecognized interp option: ", ip + iret=1 + print*,"Unrecognized interp option: ",ip error stop - end select + endselect - end subroutine ipolates_grid + endsubroutine ipolates_grid !> Special case of ipolates_grib1 when interpolating a single field. !! Removes the km dimension of input arrays so scalars can be passed to ibi/ibo. @@ -155,55 +155,55 @@ end subroutine ipolates_grid !! !! @date Jan 2022 !! @author Kyle Gerheiser - subroutine ipolates_grib1_single_field(ip, ipopt, kgdsi, kgdso, mi, mo, km, ibi, li, gi, & - no, rlat, rlon, ibo, lo, go, iret) bind(c) + subroutine ipolates_grib1_single_field(ip,ipopt,kgdsi,kgdso,mi,mo,km,ibi,li,gi, & + no,rlat,rlon,ibo,lo,go,iret) bind(c) ! - use iso_c_binding, only: c_int, c_float, c_double, c_bool, c_long + use iso_c_binding,only:c_int,c_float,c_double,c_bool,c_long #if (LSIZE==8) - integer(c_long), intent(in) :: ip, ipopt(20), km, mi, mo - integer(c_long), intent(in) :: ibi, kgdsi(200), kgdso(200) - integer(c_long), intent(inout) :: no - integer(c_long), intent(out) :: iret, ibo + integer(c_long),intent(in) :: ip,ipopt(20),km,mi,mo + integer(c_long),intent(in) :: ibi,kgdsi(200),kgdso(200) + integer(c_long),intent(inout) :: no + integer(c_long),intent(out) :: iret,ibo #else - integer(c_int), intent(in) :: ip, ipopt(20), km, mi, mo - integer(c_int), intent(in) :: ibi, kgdsi(200), kgdso(200) - integer(c_int), intent(inout) :: no - integer(c_int), intent(out) :: iret, ibo + integer(c_int),intent(in) :: ip,ipopt(20),km,mi,mo + integer(c_int),intent(in) :: ibi,kgdsi(200),kgdso(200) + integer(c_int),intent(inout) :: no + integer(c_int),intent(out) :: iret,ibo #endif ! - logical(c_bool), intent(in) :: li(mi) - logical(c_bool), intent(out) :: lo(mo) + logical(c_bool),intent(in) :: li(mi) + logical(c_bool),intent(out) :: lo(mo) ! #if (LSIZE==4) - real(c_float), intent(in) :: gi(mi) - real(c_float), intent(inout) :: rlat(mo), rlon(mo) - real(c_float), intent(out) :: go(mo) + real(c_float),intent(in) :: gi(mi) + real(c_float),intent(inout) :: rlat(mo),rlon(mo) + real(c_float),intent(out) :: go(mo) #else - real(c_double), intent(in) :: gi(mi) - real(c_double), intent(inout) :: rlat(mo), rlon(mo) - real(c_double), intent(out) :: go(mo) + real(c_double),intent(in) :: gi(mi) + real(c_double),intent(inout) :: rlat(mo),rlon(mo) + real(c_double),intent(out) :: go(mo) #endif ! - type(grib1_descriptor) :: desc_in, desc_out - class(ip_grid), allocatable :: grid_in, grid_out + type(grib1_descriptor) :: desc_in,desc_out + class(ip_grid),allocatable :: grid_in,grid_out integer :: ibo_array(1) - desc_in = init_descriptor(kgdsi) - desc_out = init_descriptor(kgdso) + desc_in=init_descriptor(kgdsi) + desc_out=init_descriptor(kgdso) - call init_grid(grid_in, desc_in) - call init_grid(grid_out, desc_out) + call init_grid(grid_in,desc_in) + call init_grid(grid_out,desc_out) ! Can't pass expression (e.g. [ibo]) to intent(out) argument. ! Initialize placeholder array of size 1 to make rank match. - ibo_array(1) = ibo + ibo_array(1)=ibo - call ipolates_grid(ip, ipopt, grid_in, grid_out, mi, mo, km, [ibi], li, gi, no, rlat, rlon, ibo_array, lo, go, iret) + call ipolates_grid(ip,ipopt,grid_in,grid_out,mi,mo,km,[ibi],li,gi,no,rlat,rlon,ibo_array,lo,go,iret) - ibo = ibo_array(1) + ibo=ibo_array(1) - end subroutine ipolates_grib1_single_field + endsubroutine ipolates_grib1_single_field !> This subprogram interpolates scalar field from any grid !! to any grid given a grib1 Grid Descriptor Section. @@ -290,48 +290,48 @@ end subroutine ipolates_grib1_single_field !! - 4x Invalid spectral method parameters. !! !! @author Mark Iredell, Kyle Gerheiser - subroutine ipolates_grib1(ip, ipopt, kgdsi, kgdso, mi, mo, km, ibi, li, gi, & - no, rlat, rlon, ibo, lo, go, iret) bind(c) + subroutine ipolates_grib1(ip,ipopt,kgdsi,kgdso,mi,mo,km,ibi,li,gi, & + no,rlat,rlon,ibo,lo,go,iret) bind(c) ! - use iso_c_binding, only: c_int, c_float, c_double, c_bool, c_long + use iso_c_binding,only:c_int,c_float,c_double,c_bool,c_long #if (LSIZE==8) - integer(c_long), intent(in) :: ip, ipopt(20), km, mi, mo - integer(c_long), intent(in) :: ibi(km), kgdsi(200), kgdso(200) - integer(c_long), intent(inout) :: no - integer(c_long), intent(out) :: iret, ibo(km) + integer(c_long),intent(in) :: ip,ipopt(20),km,mi,mo + integer(c_long),intent(in) :: ibi(km),kgdsi(200),kgdso(200) + integer(c_long),intent(inout) :: no + integer(c_long),intent(out) :: iret,ibo(km) #else - integer(c_int), intent(in) :: ip, ipopt(20), km, mi, mo - integer(c_int), intent(in) :: ibi(km), kgdsi(200), kgdso(200) - integer(c_int), intent(inout) :: no - integer(c_int), intent(out) :: iret, ibo(km) + integer(c_int),intent(in) :: ip,ipopt(20),km,mi,mo + integer(c_int),intent(in) :: ibi(km),kgdsi(200),kgdso(200) + integer(c_int),intent(inout) :: no + integer(c_int),intent(out) :: iret,ibo(km) #endif ! - logical(c_bool), intent(in) :: li(mi, km) - logical(c_bool), intent(out) :: lo(mo, km) + logical(c_bool),intent(in) :: li(mi,km) + logical(c_bool),intent(out) :: lo(mo,km) ! #if (LSIZE==4) - real(c_float), intent(in) :: gi(mi, km) - real(c_float), intent(inout) :: rlat(mo), rlon(mo) - real(c_float), intent(out) :: go(mo, km) + real(c_float),intent(in) :: gi(mi,km) + real(c_float),intent(inout) :: rlat(mo),rlon(mo) + real(c_float),intent(out) :: go(mo,km) #else - real(c_double), intent(in) :: gi(mi, km) - real(c_double), intent(inout) :: rlat(mo), rlon(mo) - real(c_double), intent(out) :: go(mo, km) + real(c_double),intent(in) :: gi(mi,km) + real(c_double),intent(inout) :: rlat(mo),rlon(mo) + real(c_double),intent(out) :: go(mo,km) #endif ! - type(grib1_descriptor) :: desc_in, desc_out - class(ip_grid), allocatable :: grid_in, grid_out + type(grib1_descriptor) :: desc_in,desc_out + class(ip_grid),allocatable :: grid_in,grid_out - desc_in = init_descriptor(kgdsi) - desc_out = init_descriptor(kgdso) + desc_in=init_descriptor(kgdsi) + desc_out=init_descriptor(kgdso) - call init_grid(grid_in, desc_in) - call init_grid(grid_out, desc_out) + call init_grid(grid_in,desc_in) + call init_grid(grid_out,desc_out) - call ipolates_grid(ip, ipopt, grid_in, grid_out, mi, mo, km, ibi, li, gi, no, rlat, rlon, ibo, lo, go, iret) + call ipolates_grid(ip,ipopt,grid_in,grid_out,mi,mo,km,ibi,li,gi,no,rlat,rlon,ibo,lo,go,iret) - end subroutine ipolates_grib1 + endsubroutine ipolates_grib1 !> This subprogram interpolates scalar field from any grid to any !! grid given a grib2 descriptor. @@ -584,56 +584,56 @@ end subroutine ipolates_grib1 !! N-BUDGET| 6 | -1,-1 | 0.18 !! !! @author Mark Iredell, Kyle Gerheiser - subroutine ipolates_grib2(ip, ipopt, igdtnumi, igdtmpli, igdtleni, & - igdtnumo, igdtmplo, igdtleno, & - mi, mo, km, ibi, li, gi, & - no, rlat, rlon, ibo, lo, go, iret) bind(c) - use iso_c_binding, only: c_int, c_float, c_double, c_bool, c_long + subroutine ipolates_grib2(ip,ipopt,igdtnumi,igdtmpli,igdtleni, & + igdtnumo,igdtmplo,igdtleno, & + mi,mo,km,ibi,li,gi, & + no,rlat,rlon,ibo,lo,go,iret) bind(c) + use iso_c_binding,only:c_int,c_float,c_double,c_bool,c_long #if (LSIZE==8) - integer(c_long), intent(in) :: ip, ipopt(20), km, mi, mo - integer(c_long), intent(in) :: ibi(km) - integer(c_long), intent(in) :: igdtnumi, igdtleni - integer(c_long), intent(in) :: igdtmpli(igdtleni) - integer(c_long), intent(in) :: igdtnumo, igdtleno - integer(c_long), intent(in) :: igdtmplo(igdtleno) - integer(c_long), intent(out) :: no - integer(c_long), intent(out) :: iret, ibo(km) + integer(c_long),intent(in) :: ip,ipopt(20),km,mi,mo + integer(c_long),intent(in) :: ibi(km) + integer(c_long),intent(in) :: igdtnumi,igdtleni + integer(c_long),intent(in) :: igdtmpli(igdtleni) + integer(c_long),intent(in) :: igdtnumo,igdtleno + integer(c_long),intent(in) :: igdtmplo(igdtleno) + integer(c_long),intent(out) :: no + integer(c_long),intent(out) :: iret,ibo(km) #else - integer(c_int), intent(in) :: ip, ipopt(20), km, mi, mo - integer(c_int), intent(in) :: ibi(km) - integer(c_int), intent(in) :: igdtnumi, igdtleni - integer(c_int), intent(in) :: igdtmpli(igdtleni) - integer(c_int), intent(in) :: igdtnumo, igdtleno - integer(c_int), intent(in) :: igdtmplo(igdtleno) - integer(c_int), intent(out) :: no - integer(c_int), intent(out) :: iret, ibo(km) + integer(c_int),intent(in) :: ip,ipopt(20),km,mi,mo + integer(c_int),intent(in) :: ibi(km) + integer(c_int),intent(in) :: igdtnumi,igdtleni + integer(c_int),intent(in) :: igdtmpli(igdtleni) + integer(c_int),intent(in) :: igdtnumo,igdtleno + integer(c_int),intent(in) :: igdtmplo(igdtleno) + integer(c_int),intent(out) :: no + integer(c_int),intent(out) :: iret,ibo(km) #endif ! - logical(c_bool), intent(in) :: li(mi, km) - logical(c_bool), intent(out) :: lo(mo, km) + logical(c_bool),intent(in) :: li(mi,km) + logical(c_bool),intent(out) :: lo(mo,km) ! #if (LSIZE==4) - real(c_float), intent(in) :: gi(mi, km) - real(c_float), intent(inout) :: rlat(mo), rlon(mo) - real(c_float), intent(out) :: go(mo, km) + real(c_float),intent(in) :: gi(mi,km) + real(c_float),intent(inout) :: rlat(mo),rlon(mo) + real(c_float),intent(out) :: go(mo,km) #else - real(c_double), intent(in) :: gi(mi, km) - real(c_double), intent(inout) :: rlat(mo), rlon(mo) - real(c_double), intent(out) :: go(mo, km) + real(c_double),intent(in) :: gi(mi,km) + real(c_double),intent(inout) :: rlat(mo),rlon(mo) + real(c_double),intent(out) :: go(mo,km) #endif - type(grib2_descriptor) :: desc_in, desc_out - class(ip_grid), allocatable :: grid_in, grid_out + type(grib2_descriptor) :: desc_in,desc_out + class(ip_grid),allocatable :: grid_in,grid_out - desc_in = init_descriptor(igdtnumi, igdtleni, igdtmpli) - desc_out = init_descriptor(igdtnumo, igdtleno, igdtmplo) + desc_in=init_descriptor(igdtnumi,igdtleni,igdtmpli) + desc_out=init_descriptor(igdtnumo,igdtleno,igdtmplo) - call init_grid(grid_in, desc_in) - call init_grid(grid_out, desc_out) + call init_grid(grid_in,desc_in) + call init_grid(grid_out,desc_out) - call ipolates_grid(ip, ipopt, grid_in, grid_out, mi, mo, km, ibi, li, gi, no, rlat, rlon, ibo, lo, go, iret) + call ipolates_grid(ip,ipopt,grid_in,grid_out,mi,mo,km,ibi,li,gi,no,rlat,rlon,ibo,lo,go,iret) - end subroutine ipolates_grib2 + endsubroutine ipolates_grib2 !> Special case of ipolates_grib2 when interpolating a single field. !! Removes the km dimension of input arrays so scalars can be passed to ibi/ibo. @@ -805,63 +805,63 @@ end subroutine ipolates_grib2 !! - 4x Invalid spectral method parameters. !! !! @author Eric Engle @date November 2022 - subroutine ipolates_grib2_single_field(ip, ipopt, igdtnumi, igdtmpli, igdtleni, & - igdtnumo, igdtmplo, igdtleno, & - mi, mo, km, ibi, li, gi, & - no, rlat, rlon, ibo, lo, go, iret) bind(c) - use iso_c_binding, only: c_int, c_float, c_double, c_bool, c_long + subroutine ipolates_grib2_single_field(ip,ipopt,igdtnumi,igdtmpli,igdtleni, & + igdtnumo,igdtmplo,igdtleno, & + mi,mo,km,ibi,li,gi, & + no,rlat,rlon,ibo,lo,go,iret) bind(c) + use iso_c_binding,only:c_int,c_float,c_double,c_bool,c_long #if (LSIZE==8) - integer(c_long), intent(in) :: ip, ipopt(20), km, mi, mo - integer(c_long), intent(in) :: ibi - integer(c_long), intent(in) :: igdtnumi, igdtleni - integer(c_long), intent(in) :: igdtmpli(igdtleni) - integer(c_long), intent(in) :: igdtnumo, igdtleno - integer(c_long), intent(in) :: igdtmplo(igdtleno) - integer(c_long), intent(out) :: no - integer(c_long), intent(out) :: iret, ibo + integer(c_long),intent(in) :: ip,ipopt(20),km,mi,mo + integer(c_long),intent(in) :: ibi + integer(c_long),intent(in) :: igdtnumi,igdtleni + integer(c_long),intent(in) :: igdtmpli(igdtleni) + integer(c_long),intent(in) :: igdtnumo,igdtleno + integer(c_long),intent(in) :: igdtmplo(igdtleno) + integer(c_long),intent(out) :: no + integer(c_long),intent(out) :: iret,ibo #else - integer(c_int), intent(in) :: ip, ipopt(20), km, mi, mo - integer(c_int), intent(in) :: ibi - integer(c_int), intent(in) :: igdtnumi, igdtleni - integer(c_int), intent(in) :: igdtmpli(igdtleni) - integer(c_int), intent(in) :: igdtnumo, igdtleno - integer(c_int), intent(in) :: igdtmplo(igdtleno) - integer(c_int), intent(out) :: no - integer(c_int), intent(out) :: iret, ibo + integer(c_int),intent(in) :: ip,ipopt(20),km,mi,mo + integer(c_int),intent(in) :: ibi + integer(c_int),intent(in) :: igdtnumi,igdtleni + integer(c_int),intent(in) :: igdtmpli(igdtleni) + integer(c_int),intent(in) :: igdtnumo,igdtleno + integer(c_int),intent(in) :: igdtmplo(igdtleno) + integer(c_int),intent(out) :: no + integer(c_int),intent(out) :: iret,ibo #endif ! - logical(c_bool), intent(in) :: li(mi) - logical(c_bool), intent(out) :: lo(mo) + logical(c_bool),intent(in) :: li(mi) + logical(c_bool),intent(out) :: lo(mo) ! #if (LSIZE==4) - real(c_float), intent(in) :: gi(mi) - real(c_float), intent(inout) :: rlat(mo), rlon(mo) - real(c_float), intent(out) :: go(mo) + real(c_float),intent(in) :: gi(mi) + real(c_float),intent(inout) :: rlat(mo),rlon(mo) + real(c_float),intent(out) :: go(mo) #else - real(c_double), intent(in) :: gi(mi) - real(c_double), intent(inout) :: rlat(mo), rlon(mo) - real(c_double), intent(out) :: go(mo) + real(c_double),intent(in) :: gi(mi) + real(c_double),intent(inout) :: rlat(mo),rlon(mo) + real(c_double),intent(out) :: go(mo) #endif - type(grib2_descriptor) :: desc_in, desc_out - class(ip_grid), allocatable :: grid_in, grid_out + type(grib2_descriptor) :: desc_in,desc_out + class(ip_grid),allocatable :: grid_in,grid_out integer :: ibo_array(1) - desc_in = init_descriptor(igdtnumi, igdtleni, igdtmpli) - desc_out = init_descriptor(igdtnumo, igdtleno, igdtmplo) + desc_in=init_descriptor(igdtnumi,igdtleni,igdtmpli) + desc_out=init_descriptor(igdtnumo,igdtleno,igdtmplo) - call init_grid(grid_in, desc_in) - call init_grid(grid_out, desc_out) + call init_grid(grid_in,desc_in) + call init_grid(grid_out,desc_out) ! Can't pass expression (e.g. [ibo]) to intent(out) argument. ! Initialize placeholder array of size 1 to make rank match. - ibo_array(1) = ibo + ibo_array(1)=ibo - call ipolates_grid(ip, ipopt, grid_in, grid_out, mi, mo, km, [ibi], li, gi, no, rlat, rlon, ibo_array, lo, go, iret) + call ipolates_grid(ip,ipopt,grid_in,grid_out,mi,mo,km,[ibi],li,gi,no,rlat,rlon,ibo_array,lo,go,iret) - ibo = ibo_array(1) + ibo=ibo_array(1) - end subroutine ipolates_grib2_single_field + endsubroutine ipolates_grib2_single_field -end module ipolates_mod +endmodule ipolates_mod diff --git a/src/ipolatev.F90 b/src/ipolatev.F90 index 02ed38c3..6dbf6d84 100644 --- a/src/ipolatev.F90 +++ b/src/ipolatev.F90 @@ -16,14 +16,14 @@ module ipolatev_mod implicit none private - public :: ipolatev, ipolatev_grib2, ipolatev_grib1_single_field, ipolatev_grib1, ipolatev_grib2_single_field + public :: ipolatev,ipolatev_grib2,ipolatev_grib1_single_field,ipolatev_grib1,ipolatev_grib2_single_field interface ipolatev module procedure ipolatev_grib1 module procedure ipolatev_grib1_single_field module procedure ipolatev_grib2 module procedure ipolatev_grib2_single_field - end interface ipolatev + endinterface ipolatev contains @@ -64,45 +64,45 @@ module ipolatev_mod !> - 4x Invalid spectral method parameters. !> @date July 2021 !> @author Kyle Gerheiser - subroutine ipolatev_grid(ip, ipopt, grid_in, grid_out, & - mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - class(ip_grid), intent(in) :: grid_in, grid_out - integer, intent(in) :: ip, ipopt(20), ibi(km) - integer, intent(in) :: km, mi, mo - integer, intent(out) :: ibo(km), iret, no + subroutine ipolatev_grid(ip,ipopt,grid_in,grid_out, & + mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + class(ip_grid),intent(in) :: grid_in,grid_out + integer,intent(in) :: ip,ipopt(20),ibi(km) + integer,intent(in) :: km,mi,mo + integer,intent(out) :: ibo(km),iret,no ! - logical*1, intent(in) :: li(mi, km) - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(in) :: li(mi,km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: ui(mi, km), vi(mi, km) - real, intent(inout) :: crot(mo), srot(mo) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: uo(mo, km), vo(mo, km) - - select case (ip) - case (bilinear_interp_id) - call interpolate_bilinear(ipopt, grid_in, grid_out, & - mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - case (bicubic_interp_id) - call interpolate_bicubic(ipopt, grid_in, grid_out, mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - case (neighbor_interp_id) - call interpolate_neighbor(ipopt, grid_in, grid_out, mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - case (budget_interp_id) - call interpolate_budget(ipopt, grid_in, grid_out, mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - case (spectral_interp_id) - call interpolate_spectral(ipopt, grid_in, grid_out, & - mi, mo, km, ibi, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - case (neighbor_budget_interp_id) - call interpolate_neighbor_budget(ipopt, grid_in, grid_out, mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) + real,intent(in) :: ui(mi,km),vi(mi,km) + real,intent(inout) :: crot(mo),srot(mo) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: uo(mo,km),vo(mo,km) + + select case(ip) + case(bilinear_interp_id) + call interpolate_bilinear(ipopt,grid_in,grid_out, & + mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + case(bicubic_interp_id) + call interpolate_bicubic(ipopt,grid_in,grid_out,mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + case(neighbor_interp_id) + call interpolate_neighbor(ipopt,grid_in,grid_out,mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + case(budget_interp_id) + call interpolate_budget(ipopt,grid_in,grid_out,mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + case(spectral_interp_id) + call interpolate_spectral(ipopt,grid_in,grid_out, & + mi,mo,km,ibi,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + case(neighbor_budget_interp_id) + call interpolate_neighbor_budget(ipopt,grid_in,grid_out,mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) case default - print *, "unrecognized interpolation option: ", ip + print*,"unrecognized interpolation option: ",ip error stop ! IF(IGDTNUMO.GE.0) NO=0 ! DO K=1,KM @@ -114,9 +114,9 @@ subroutine ipolatev_grid(ip, ipopt, grid_in, grid_out, & ! ENDDO ! ENDDO ! IRET=1 - end select + endselect - end subroutine ipolatev_grid + endsubroutine ipolatev_grid !> This subprogram interpolates vector fields from any grid to any !> grid given a grib2 descriptor. @@ -379,59 +379,59 @@ end subroutine ipolatev_grid !> N-BUDGET| 6 | -1,-1 | 0.33 !> !> @author Kyle Gerheiser @date July 2021 - subroutine ipolatev_grib2(ip, ipopt, igdtnumi, igdtmpli, igdtleni, & - igdtnumo, igdtmplo, igdtleno, & - mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) bind(c) - use iso_c_binding, only: c_int, c_float, c_double, c_bool, c_long + subroutine ipolatev_grib2(ip,ipopt,igdtnumi,igdtmpli,igdtleni, & + igdtnumo,igdtmplo,igdtleno, & + mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) bind(c) + use iso_c_binding,only:c_int,c_float,c_double,c_bool,c_long #if (LSIZE==8) - integer(c_long), intent(in) :: ip, ipopt(20), ibi(km) - integer(c_long), intent(in) :: km, mi, mo - integer(c_long), intent(in) :: igdtnumi, igdtleni - integer(c_long), intent(in) :: igdtmpli(igdtleni) - integer(c_long), intent(in) :: igdtnumo, igdtleno - integer(c_long), intent(in) :: igdtmplo(igdtleno) - integer(c_long), intent(out) :: ibo(km), iret, no + integer(c_long),intent(in) :: ip,ipopt(20),ibi(km) + integer(c_long),intent(in) :: km,mi,mo + integer(c_long),intent(in) :: igdtnumi,igdtleni + integer(c_long),intent(in) :: igdtmpli(igdtleni) + integer(c_long),intent(in) :: igdtnumo,igdtleno + integer(c_long),intent(in) :: igdtmplo(igdtleno) + integer(c_long),intent(out) :: ibo(km),iret,no #else - integer(c_int), intent(in) :: ip, ipopt(20), ibi(km) - integer(c_int), intent(in) :: km, mi, mo - integer(c_int), intent(in) :: igdtnumi, igdtleni - integer(c_int), intent(in) :: igdtmpli(igdtleni) - integer(c_int), intent(in) :: igdtnumo, igdtleno - integer(c_int), intent(in) :: igdtmplo(igdtleno) - integer(c_int), intent(out) :: ibo(km), iret, no + integer(c_int),intent(in) :: ip,ipopt(20),ibi(km) + integer(c_int),intent(in) :: km,mi,mo + integer(c_int),intent(in) :: igdtnumi,igdtleni + integer(c_int),intent(in) :: igdtmpli(igdtleni) + integer(c_int),intent(in) :: igdtnumo,igdtleno + integer(c_int),intent(in) :: igdtmplo(igdtleno) + integer(c_int),intent(out) :: ibo(km),iret,no #endif ! - logical(c_bool), intent(in) :: li(mi, km) - logical(c_bool), intent(out) :: lo(mo, km) + logical(c_bool),intent(in) :: li(mi,km) + logical(c_bool),intent(out) :: lo(mo,km) ! #if (LSIZE==4) - real(c_float), intent(in) :: ui(mi, km), vi(mi, km) - real(c_float), intent(inout) :: crot(mo), srot(mo) - real(c_float), intent(inout) :: rlat(mo), rlon(mo) - real(c_float), intent(out) :: uo(mo, km), vo(mo, km) + real(c_float),intent(in) :: ui(mi,km),vi(mi,km) + real(c_float),intent(inout) :: crot(mo),srot(mo) + real(c_float),intent(inout) :: rlat(mo),rlon(mo) + real(c_float),intent(out) :: uo(mo,km),vo(mo,km) #else - real(c_double), intent(in) :: ui(mi, km), vi(mi, km) - real(c_double), intent(inout) :: crot(mo), srot(mo) - real(c_double), intent(inout) :: rlat(mo), rlon(mo) - real(c_double), intent(out) :: uo(mo, km), vo(mo, km) + real(c_double),intent(in) :: ui(mi,km),vi(mi,km) + real(c_double),intent(inout) :: crot(mo),srot(mo) + real(c_double),intent(inout) :: rlat(mo),rlon(mo) + real(c_double),intent(out) :: uo(mo,km),vo(mo,km) #endif ! - type(grib2_descriptor) :: desc_in, desc_out - class(ip_grid), allocatable :: grid_in, grid_out + type(grib2_descriptor) :: desc_in,desc_out + class(ip_grid),allocatable :: grid_in,grid_out - desc_in = init_descriptor(igdtnumi, igdtleni, igdtmpli) - desc_out = init_descriptor(igdtnumo, igdtleno, igdtmplo) + desc_in=init_descriptor(igdtnumi,igdtleni,igdtmpli) + desc_out=init_descriptor(igdtnumo,igdtleno,igdtmplo) - call init_grid(grid_in, desc_in) - call init_grid(grid_out, desc_out) + call init_grid(grid_in,desc_in) + call init_grid(grid_out,desc_out) - call ipolatev_grid(ip, ipopt, grid_in, grid_out, & - mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) + call ipolatev_grid(ip,ipopt,grid_in,grid_out, & + mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) - end subroutine ipolatev_grib2 + endsubroutine ipolatev_grib2 !> @brief This subprogram interpolates vector field from any grid !> to any grid given a grib1 Grid Descriptor Section. @@ -562,70 +562,70 @@ end subroutine ipolatev_grib2 !> !> @date July 2021 !> @author Kyle Gerheiser - subroutine ipolatev_grib1(ip, ipopt, kgdsi, kgdso, mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) bind(c) - use iso_c_binding, only: c_int, c_float, c_double, c_bool, c_long + subroutine ipolatev_grib1(ip,ipopt,kgdsi,kgdso,mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) bind(c) + use iso_c_binding,only:c_int,c_float,c_double,c_bool,c_long implicit none ! #if (LSIZE==8) - integer(c_long), intent(in):: ip, ipopt(20), ibi(km) - integer(c_long), intent(in):: km, mi, mo - integer(c_long), intent(inout):: kgdsi(200), kgdso(200) - integer(c_long), intent(out):: ibo(km), iret, no + integer(c_long),intent(in):: ip,ipopt(20),ibi(km) + integer(c_long),intent(in):: km,mi,mo + integer(c_long),intent(inout):: kgdsi(200),kgdso(200) + integer(c_long),intent(out):: ibo(km),iret,no #else - integer(c_int), intent(in):: ip, ipopt(20), ibi(km) - integer(c_int), intent(in):: km, mi, mo - integer(c_int), intent(inout):: kgdsi(200), kgdso(200) - integer(c_int), intent(out):: ibo(km), iret, no + integer(c_int),intent(in):: ip,ipopt(20),ibi(km) + integer(c_int),intent(in):: km,mi,mo + integer(c_int),intent(inout):: kgdsi(200),kgdso(200) + integer(c_int),intent(out):: ibo(km),iret,no #endif ! - logical(c_bool), intent(in):: li(mi, km) - logical(c_bool), intent(out):: lo(mo, km) + logical(c_bool),intent(in):: li(mi,km) + logical(c_bool),intent(out):: lo(mo,km) ! #if (LSIZE==4) - real(c_float), intent(in):: ui(mi, km), vi(mi, km) - real(c_float), intent(inout):: crot(mo), srot(mo) - real(c_float), intent(inout):: rlat(mo), rlon(mo) - real(c_float), intent(out):: uo(mo, km), vo(mo, km) + real(c_float),intent(in):: ui(mi,km),vi(mi,km) + real(c_float),intent(inout):: crot(mo),srot(mo) + real(c_float),intent(inout):: rlat(mo),rlon(mo) + real(c_float),intent(out):: uo(mo,km),vo(mo,km) #else - real(c_double), intent(in):: ui(mi, km), vi(mi, km) - real(c_double), intent(inout):: crot(mo), srot(mo) - real(c_double), intent(inout):: rlat(mo), rlon(mo) - real(c_double), intent(out):: uo(mo, km), vo(mo, km) + real(c_double),intent(in):: ui(mi,km),vi(mi,km) + real(c_double),intent(inout):: crot(mo),srot(mo) + real(c_double),intent(inout):: rlat(mo),rlon(mo) + real(c_double),intent(out):: uo(mo,km),vo(mo,km) #endif ! - integer :: kgdsi11, kgdso11 + integer :: kgdsi11,kgdso11 - type(grib1_descriptor) :: desc_in, desc_out - class(ip_grid), allocatable :: grid_in, grid_out + type(grib1_descriptor) :: desc_in,desc_out + class(ip_grid),allocatable :: grid_in,grid_out - if (kgdsi(1) .eq. 203) then - kgdsi11 = kgdsi(11) - kgdsi(11) = ior(kgdsi(11), 256) - end if - if (kgdso(1) .eq. 203) then - kgdso11 = kgdso(11) - kgdso(11) = ior(kgdso(11), 256) - end if + if(kgdsi(1).eq.203) then + kgdsi11=kgdsi(11) + kgdsi(11)=ior(kgdsi(11),256) + endif + if(kgdso(1).eq.203) then + kgdso11=kgdso(11) + kgdso(11)=ior(kgdso(11),256) + endif - desc_in = init_descriptor(kgdsi) - desc_out = init_descriptor(kgdso) + desc_in=init_descriptor(kgdsi) + desc_out=init_descriptor(kgdso) - call init_grid(grid_in, desc_in) - call init_grid(grid_out, desc_out) + call init_grid(grid_in,desc_in) + call init_grid(grid_out,desc_out) - call ipolatev_grid(ip, ipopt, grid_in, grid_out, & - mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) + call ipolatev_grid(ip,ipopt,grid_in,grid_out, & + mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) - if (kgdsi(1) .eq. 203) then - kgdsi(11) = kgdsi11 - end if - if (kgdso(1) .eq. 203) then - kgdso(11) = kgdso11 - end if + if(kgdsi(1).eq.203) then + kgdsi(11)=kgdsi11 + endif + if(kgdso(1).eq.203) then + kgdso(11)=kgdso11 + endif - end subroutine ipolatev_grib1 + endsubroutine ipolatev_grib1 !> Special case of ipolatev_grib1 when interpolating a single field. !> @@ -677,77 +677,77 @@ end subroutine ipolatev_grib1 !> !> @date Jan 2022 !> @author Kyle Gerheiser - subroutine ipolatev_grib1_single_field(ip, ipopt, kgdsi, kgdso, mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) bind(c) - use iso_c_binding, only: c_int, c_float, c_double, c_bool, c_long + subroutine ipolatev_grib1_single_field(ip,ipopt,kgdsi,kgdso,mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) bind(c) + use iso_c_binding,only:c_int,c_float,c_double,c_bool,c_long implicit none ! #if (LSIZE==8) - integer(c_long), intent(in):: ip, ipopt(20), ibi - integer(c_long), intent(in):: km, mi, mo - integer(c_long), intent(inout):: kgdsi(200), kgdso(200) - integer(c_long), intent(out):: ibo, iret, no + integer(c_long),intent(in):: ip,ipopt(20),ibi + integer(c_long),intent(in):: km,mi,mo + integer(c_long),intent(inout):: kgdsi(200),kgdso(200) + integer(c_long),intent(out):: ibo,iret,no #else - integer(c_int), intent(in):: ip, ipopt(20), ibi - integer(c_int), intent(in):: km, mi, mo - integer(c_int), intent(inout):: kgdsi(200), kgdso(200) - integer(c_int), intent(out):: ibo, iret, no + integer(c_int),intent(in):: ip,ipopt(20),ibi + integer(c_int),intent(in):: km,mi,mo + integer(c_int),intent(inout):: kgdsi(200),kgdso(200) + integer(c_int),intent(out):: ibo,iret,no #endif ! - logical(c_bool), intent(in):: li(mi) - logical(c_bool), intent(out):: lo(mo) + logical(c_bool),intent(in):: li(mi) + logical(c_bool),intent(out):: lo(mo) ! #if (LSIZE==4) - real(c_float), intent(in):: ui(mi), vi(mi) - real(c_float), intent(inout):: crot(mo), srot(mo) - real(c_float), intent(inout):: rlat(mo), rlon(mo) - real(c_float), intent(out):: uo(mo), vo(mo) + real(c_float),intent(in):: ui(mi),vi(mi) + real(c_float),intent(inout):: crot(mo),srot(mo) + real(c_float),intent(inout):: rlat(mo),rlon(mo) + real(c_float),intent(out):: uo(mo),vo(mo) #else - real(c_double), intent(in):: ui(mi), vi(mi) - real(c_double), intent(inout):: crot(mo), srot(mo) - real(c_double), intent(inout):: rlat(mo), rlon(mo) - real(c_double), intent(out):: uo(mo), vo(mo) + real(c_double),intent(in):: ui(mi),vi(mi) + real(c_double),intent(inout):: crot(mo),srot(mo) + real(c_double),intent(inout):: rlat(mo),rlon(mo) + real(c_double),intent(out):: uo(mo),vo(mo) #endif ! - integer :: kgdsi11, kgdso11 + integer :: kgdsi11,kgdso11 - type(grib1_descriptor) :: desc_in, desc_out - class(ip_grid), allocatable :: grid_in, grid_out + type(grib1_descriptor) :: desc_in,desc_out + class(ip_grid),allocatable :: grid_in,grid_out integer :: ibo_array(1) ! Can't pass expression (e.g. [ibo]) to intent(out) argument. ! Initialize placeholder array of size 1 to make rank match. - ibo_array(1) = ibo + ibo_array(1)=ibo - if (kgdsi(1) .eq. 203) then - kgdsi11 = kgdsi(11) - kgdsi(11) = ior(kgdsi(11), 256) - end if - if (kgdso(1) .eq. 203) then - kgdso11 = kgdso(11) - kgdso(11) = ior(kgdso(11), 256) - end if + if(kgdsi(1).eq.203) then + kgdsi11=kgdsi(11) + kgdsi(11)=ior(kgdsi(11),256) + endif + if(kgdso(1).eq.203) then + kgdso11=kgdso(11) + kgdso(11)=ior(kgdso(11),256) + endif - desc_in = init_descriptor(kgdsi) - desc_out = init_descriptor(kgdso) + desc_in=init_descriptor(kgdsi) + desc_out=init_descriptor(kgdso) - call init_grid(grid_in, desc_in) - call init_grid(grid_out, desc_out) + call init_grid(grid_in,desc_in) + call init_grid(grid_out,desc_out) - call ipolatev_grid(ip, ipopt, grid_in, grid_out, & - mi, mo, km, [ibi], li, ui, vi, & - no, rlat, rlon, crot, srot, ibo_array, lo, uo, vo, iret) + call ipolatev_grid(ip,ipopt,grid_in,grid_out, & + mi,mo,km,[ibi],li,ui,vi, & + no,rlat,rlon,crot,srot,ibo_array,lo,uo,vo,iret) - ibo = ibo_array(1) + ibo=ibo_array(1) - if (kgdsi(1) .eq. 203) then - kgdsi(11) = kgdsi11 - end if - if (kgdso(1) .eq. 203) then - kgdso(11) = kgdso11 - end if + if(kgdsi(1).eq.203) then + kgdsi(11)=kgdsi11 + endif + if(kgdso(1).eq.203) then + kgdso(11)=kgdso11 + endif - end subroutine ipolatev_grib1_single_field + endsubroutine ipolatev_grib1_single_field !> This subprogram interpolates vector fields from any grid to any !> grid given a grib2 descriptor. @@ -829,66 +829,66 @@ end subroutine ipolatev_grib1_single_field !> - 4x Invalid spectral method parameters. !> !> @author Eric Engle @date November 2022 - subroutine ipolatev_grib2_single_field(ip, ipopt, igdtnumi, igdtmpli, igdtleni, & - igdtnumo, igdtmplo, igdtleno, & - mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) bind(c) - use iso_c_binding, only: c_int, c_float, c_double, c_bool, c_long + subroutine ipolatev_grib2_single_field(ip,ipopt,igdtnumi,igdtmpli,igdtleni, & + igdtnumo,igdtmplo,igdtleno, & + mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) bind(c) + use iso_c_binding,only:c_int,c_float,c_double,c_bool,c_long #if (LSIZE==8) - integer(c_long), intent(in) :: ip, ipopt(20), ibi - integer(c_long), intent(in) :: km, mi, mo - integer(c_long), intent(in) :: igdtnumi, igdtleni - integer(c_long), intent(in) :: igdtmpli(igdtleni) - integer(c_long), intent(in) :: igdtnumo, igdtleno - integer(c_long), intent(in) :: igdtmplo(igdtleno) - integer(c_long), intent(out) :: ibo, iret, no + integer(c_long),intent(in) :: ip,ipopt(20),ibi + integer(c_long),intent(in) :: km,mi,mo + integer(c_long),intent(in) :: igdtnumi,igdtleni + integer(c_long),intent(in) :: igdtmpli(igdtleni) + integer(c_long),intent(in) :: igdtnumo,igdtleno + integer(c_long),intent(in) :: igdtmplo(igdtleno) + integer(c_long),intent(out) :: ibo,iret,no #else - integer(c_int), intent(in) :: ip, ipopt(20), ibi - integer(c_int), intent(in) :: km, mi, mo - integer(c_int), intent(in) :: igdtnumi, igdtleni - integer(c_int), intent(in) :: igdtmpli(igdtleni) - integer(c_int), intent(in) :: igdtnumo, igdtleno - integer(c_int), intent(in) :: igdtmplo(igdtleno) - integer(c_int), intent(out) :: ibo, iret, no + integer(c_int),intent(in) :: ip,ipopt(20),ibi + integer(c_int),intent(in) :: km,mi,mo + integer(c_int),intent(in) :: igdtnumi,igdtleni + integer(c_int),intent(in) :: igdtmpli(igdtleni) + integer(c_int),intent(in) :: igdtnumo,igdtleno + integer(c_int),intent(in) :: igdtmplo(igdtleno) + integer(c_int),intent(out) :: ibo,iret,no #endif ! - logical(c_bool), intent(in) :: li(mi) - logical(c_bool), intent(out) :: lo(mo) + logical(c_bool),intent(in) :: li(mi) + logical(c_bool),intent(out) :: lo(mo) ! #if (LSIZE==4) - real(c_float), intent(in) :: ui(mi), vi(mi) - real(c_float), intent(inout) :: crot(mo), srot(mo) - real(c_float), intent(inout) :: rlat(mo), rlon(mo) - real(c_float), intent(out) :: uo(mo), vo(mo) + real(c_float),intent(in) :: ui(mi),vi(mi) + real(c_float),intent(inout) :: crot(mo),srot(mo) + real(c_float),intent(inout) :: rlat(mo),rlon(mo) + real(c_float),intent(out) :: uo(mo),vo(mo) #else - real(c_double), intent(in) :: ui(mi), vi(mi) - real(c_double), intent(inout) :: crot(mo), srot(mo) - real(c_double), intent(inout) :: rlat(mo), rlon(mo) - real(c_double), intent(out) :: uo(mo), vo(mo) + real(c_double),intent(in) :: ui(mi),vi(mi) + real(c_double),intent(inout) :: crot(mo),srot(mo) + real(c_double),intent(inout) :: rlat(mo),rlon(mo) + real(c_double),intent(out) :: uo(mo),vo(mo) #endif ! - type(grib2_descriptor) :: desc_in, desc_out - class(ip_grid), allocatable :: grid_in, grid_out + type(grib2_descriptor) :: desc_in,desc_out + class(ip_grid),allocatable :: grid_in,grid_out integer :: ibo_array(1) ! Can't pass expression (e.g. [ibo]) to intent(out) argument. ! Initialize placeholder array of size 1 to make rank match. - ibo_array(1) = ibo + ibo_array(1)=ibo - desc_in = init_descriptor(igdtnumi, igdtleni, igdtmpli) - desc_out = init_descriptor(igdtnumo, igdtleno, igdtmplo) + desc_in=init_descriptor(igdtnumi,igdtleni,igdtmpli) + desc_out=init_descriptor(igdtnumo,igdtleno,igdtmplo) - call init_grid(grid_in, desc_in) - call init_grid(grid_out, desc_out) + call init_grid(grid_in,desc_in) + call init_grid(grid_out,desc_out) - call ipolatev_grid(ip, ipopt, grid_in, grid_out, & - mi, mo, km, [ibi], li, ui, vi, & - no, rlat, rlon, crot, srot, ibo_array, lo, uo, vo, iret) + call ipolatev_grid(ip,ipopt,grid_in,grid_out, & + mi,mo,km,[ibi],li,ui,vi, & + no,rlat,rlon,crot,srot,ibo_array,lo,uo,vo,iret) - ibo = ibo_array(1) + ibo=ibo_array(1) - end subroutine ipolatev_grib2_single_field + endsubroutine ipolatev_grib2_single_field -end module ipolatev_mod +endmodule ipolatev_mod diff --git a/src/ipxetas.F90 b/src/ipxetas.F90 index 5ced8d52..7a51f99e 100644 --- a/src/ipxetas.F90 +++ b/src/ipxetas.F90 @@ -87,118 +87,118 @@ !> - non-0 invalid grid specs or problem in ipolates(). !> ! @author Iredell @date 96-04-10 - subroutine ipxetas(idir, igdtnumi, igdtlen, igdtmpli, npts_input, & - bitmap_input, data_input, igdtnumo, igdtmplo, & - npts_output, bitmap_output, data_output, iret) + subroutine ipxetas(idir,igdtnumi,igdtlen,igdtmpli,npts_input, & + bitmap_input,data_input,igdtnumo,igdtmplo, & + npts_output,bitmap_output,data_output,iret) use ipolates_mod implicit none ! - integer, intent(in) :: idir - integer, intent(in) :: igdtnumi, igdtlen - integer, intent(in) :: igdtmpli(igdtlen) - integer, intent(in) :: npts_input, npts_output - integer, intent(out) :: igdtnumo - integer, intent(out) :: igdtmplo(igdtlen) - integer, intent(out) :: iret + integer,intent(in) :: idir + integer,intent(in) :: igdtnumi,igdtlen + integer,intent(in) :: igdtmpli(igdtlen) + integer,intent(in) :: npts_input,npts_output + integer,intent(out) :: igdtnumo + integer,intent(out) :: igdtmplo(igdtlen) + integer,intent(out) :: iret - logical(KIND=1), intent(in) :: bitmap_input(npts_input) - logical(KIND=1), intent(out) :: bitmap_output(npts_output) + logical(KIND=1),intent(in) :: bitmap_input(npts_input) + logical(KIND=1),intent(out) :: bitmap_output(npts_output) - real, intent(in) :: data_input(npts_input) - real, intent(out) :: data_output(npts_output) + real,intent(in) :: data_input(npts_input) + real,intent(out) :: data_output(npts_output) - integer :: scan_mode, iscale, ip, ipopt(20) - integer :: ibi, ibo, j, km, no + integer :: scan_mode,iscale,ip,ipopt(20) + integer :: ibi,ibo,j,km,no real :: dlons - real, allocatable :: output_rlat(:), output_rlon(:) + real,allocatable :: output_rlat(:),output_rlon(:) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret = 0 + iret=0 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! ROUTINE ONLY WORKS FOR ROTATED LAT/LON GRIDS. - if (igdtnumi .ne. 1) then - iret = 1 + if(igdtnumi.ne.1) then + iret=1 return - end if + endif ! - scan_mode = igdtmpli(19) - if ((scan_mode .eq. 68 .or. scan_mode .eq. 72) .and. (idir .lt. -2 .or. idir .gt. -1)) then - igdtnumo = igdtnumi - igdtmplo = igdtmpli - igdtmplo(19) = 64 - igdtmplo(8) = igdtmplo(8)*2-1 - if ((igdtmplo(8)*igdtmplo(9)) .ne. npts_output) then - iret = 3 + scan_mode=igdtmpli(19) + if((scan_mode.eq.68.or.scan_mode.eq.72).and.(idir.lt.-2.or.idir.gt.-1)) then + igdtnumo=igdtnumi + igdtmplo=igdtmpli + igdtmplo(19)=64 + igdtmplo(8)=igdtmplo(8)*2-1 + if((igdtmplo(8)*igdtmplo(9)).ne.npts_output) then + iret=3 return - end if - iscale = igdtmplo(10)*igdtmplo(11) - if (iscale .eq. 0) iscale = 10**6 - dlons = float(igdtmplo(17))/float(iscale) - dlons = dlons*0.5 - igdtmplo(17) = nint(dlons*float(iscale)) - elseif (scan_mode .eq. 64 .and. idir .eq. -1) then ! FULL TO H-GRID - igdtnumo = igdtnumi - igdtmplo = igdtmpli - igdtmplo(19) = 68 - igdtmplo(8) = (igdtmplo(8)+1)/2 - if ((igdtmplo(8)*igdtmplo(9)) .ne. npts_output) then - iret = 3 + endif + iscale=igdtmplo(10)*igdtmplo(11) + if(iscale.eq.0) iscale=10**6 + dlons=float(igdtmplo(17))/float(iscale) + dlons=dlons*0.5 + igdtmplo(17)=nint(dlons*float(iscale)) + elseif(scan_mode.eq.64.and.idir.eq.-1) then ! FULL TO H-GRID + igdtnumo=igdtnumi + igdtmplo=igdtmpli + igdtmplo(19)=68 + igdtmplo(8)=(igdtmplo(8)+1)/2 + if((igdtmplo(8)*igdtmplo(9)).ne.npts_output) then + iret=3 return - end if - iscale = igdtmplo(10)*igdtmplo(11) - if (iscale .eq. 0) iscale = 10**6 - dlons = float(igdtmplo(17))/float(iscale) - dlons = dlons*2.0 - igdtmplo(17) = nint(dlons*float(iscale)) - elseif (scan_mode .eq. 64 .and. idir .eq. -2) then ! FULL TO V-GRID - igdtnumo = igdtnumi - igdtmplo = igdtmpli - igdtmplo(19) = 72 - igdtmplo(8) = (igdtmplo(8)+1)/2 - if ((igdtmplo(8)*igdtmplo(9)) .ne. npts_output) then - iret = 3 + endif + iscale=igdtmplo(10)*igdtmplo(11) + if(iscale.eq.0) iscale=10**6 + dlons=float(igdtmplo(17))/float(iscale) + dlons=dlons*2.0 + igdtmplo(17)=nint(dlons*float(iscale)) + elseif(scan_mode.eq.64.and.idir.eq.-2) then ! FULL TO V-GRID + igdtnumo=igdtnumi + igdtmplo=igdtmpli + igdtmplo(19)=72 + igdtmplo(8)=(igdtmplo(8)+1)/2 + if((igdtmplo(8)*igdtmplo(9)).ne.npts_output) then + iret=3 return - end if - iscale = igdtmplo(10)*igdtmplo(11) - if (iscale .eq. 0) iscale = 10**6 - dlons = float(igdtmplo(17))/float(iscale) - dlons = dlons*2.0 - igdtmplo(17) = nint(dlons*float(iscale)) + endif + iscale=igdtmplo(10)*igdtmplo(11) + if(iscale.eq.0) iscale=10**6 + dlons=float(igdtmplo(17))/float(iscale) + dlons=dlons*2.0 + igdtmplo(17)=nint(dlons*float(iscale)) else - iret = 2 + iret=2 return - end if + endif - km = 1 - ip = 0 - ipopt = 0 - ibi = 1 - ibo = 0 + km=1 + ip=0 + ipopt=0 + ibi=1 + ibo=0 - allocate (output_rlat(npts_output)) - allocate (output_rlon(npts_output)) + allocate(output_rlat(npts_output)) + allocate(output_rlon(npts_output)) - call ipolates(ip, ipopt, igdtnumi, igdtmpli, igdtlen, & - igdtnumo, igdtmplo, igdtlen, & - npts_input, npts_output, km, ibi, bitmap_input, data_input, & - no, output_rlat, output_rlon, ibo, bitmap_output, data_output, iret) + call ipolates(ip,ipopt,igdtnumi,igdtmpli,igdtlen, & + igdtnumo,igdtmplo,igdtlen, & + npts_input,npts_output,km,ibi,bitmap_input,data_input, & + no,output_rlat,output_rlon,ibo,bitmap_output,data_output,iret) - deallocate (output_rlat, output_rlon) + deallocate(output_rlat,output_rlon) - if (iret .ne. 0) then - print *, '- PROBLEM IN IPOLATES: ', iret + if(iret.ne.0) then + print*,'- PROBLEM IN IPOLATES: ',iret return - end if + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! REPLACE ANY UNDEFINED POINTS ALONG THE LEFT AND RIGHT EDGES. - do j = 1, igdtmplo(9) - bitmap_output(j*igdtmplo(8)) = bitmap_output(j*igdtmplo(8)-1) - data_output(j*igdtmplo(8)) = data_output(j*igdtmplo(8)-1) - bitmap_output((j-1)*igdtmplo(8)+1) = bitmap_output((j-1)*igdtmplo(8)+2) - data_output((j-1)*igdtmplo(8)+1) = data_output((j-1)*igdtmplo(8)+2) - end do + do j=1,igdtmplo(9) + bitmap_output(j*igdtmplo(8))=bitmap_output(j*igdtmplo(8)-1) + data_output(j*igdtmplo(8))=data_output(j*igdtmplo(8)-1) + bitmap_output((j-1)*igdtmplo(8)+1)=bitmap_output((j-1)*igdtmplo(8)+2) + data_output((j-1)*igdtmplo(8)+1)=data_output((j-1)*igdtmplo(8)+2) + enddo return ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine ipxetas + endsubroutine ipxetas diff --git a/src/ipxwafs.F90 b/src/ipxwafs.F90 index 2b872a8a..8e4aa592 100644 --- a/src/ipxwafs.F90 +++ b/src/ipxwafs.F90 @@ -78,148 +78,148 @@ !> - 1 improper grid specification !> !> @author Iredell @date 96-04-10 - subroutine ipxwafs(idir, numpts_thin, numpts_full, km, num_opt, & - opt_pts, igdtlen, igdtmpl_thin, data_thin, & - igdtmpl_full, data_full, iret) + subroutine ipxwafs(idir,numpts_thin,numpts_full,km,num_opt, & + opt_pts,igdtlen,igdtmpl_thin,data_thin, & + igdtmpl_full,data_full,iret) implicit none ! - integer, intent(in) :: num_opt - integer, intent(inout) :: opt_pts(num_opt) - integer, intent(in) :: idir, km, numpts_thin, numpts_full - integer, intent(in) :: igdtlen - integer, intent(inout) :: igdtmpl_thin(igdtlen) - integer, intent(inout) :: igdtmpl_full(igdtlen) - integer, intent(out) :: iret + integer,intent(in) :: num_opt + integer,intent(inout) :: opt_pts(num_opt) + integer,intent(in) :: idir,km,numpts_thin,numpts_full + integer,intent(in) :: igdtlen + integer,intent(inout) :: igdtmpl_thin(igdtlen) + integer,intent(inout) :: igdtmpl_full(igdtlen) + integer,intent(out) :: iret ! - real, intent(inout) :: data_thin(numpts_thin, km) - real, intent(inout) :: data_full(numpts_full, km) + real,intent(inout) :: data_thin(numpts_thin,km) + real,intent(inout) :: data_full(numpts_full,km) ! - integer, parameter :: missing = -1 + integer,parameter :: missing=-1 ! - integer :: scan_mode, i, j, k, idlat, idlon - integer :: ia, ib, im, im1, im2, npwafs(73) - integer :: is1, is2, iscan, iscale + integer :: scan_mode,i,j,k,idlat,idlon + integer :: ia,ib,im,im1,im2,npwafs(73) + integer :: is1,is2,iscan,iscale ! - logical :: test1, test2 + logical :: test1,test2 ! - real :: dlon, hi - real :: rat1, rat2, rlon1, rlon2 - real :: wa, wb, x1, x2 + real :: dlon,hi + real :: rat1,rat2,rlon1,rlon2 + real :: wa,wb,x1,x2 ! data npwafs/ & - 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, & - 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, & - 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, & - 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, & - 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ + 73,73,73,73,73,73,73,73,72,72,72,71,71,71,70, & + 70,69,69,68,67,67,66,65,65,64,63,62,61,60,60, & + 59,58,57,56,55,54,52,51,50,49,48,47,45,44,43, & + 42,40,39,38,36,35,33,32,30,29,28,26,25,23,22, & + 20,19,17,16,14,12,11,9,8,6,5,3,2/ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSFORM GDS - iret = 0 + iret=0 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! REG LAT/LON GRIDS HAVE 19 GDT ELEMENTS. - if (igdtlen .ne. 19 .or. numpts_thin .ne. 3447 .or. numpts_full .ne. 5329) then - iret = 1 + if(igdtlen.ne.19.or.numpts_thin.ne.3447.or.numpts_full.ne.5329) then + iret=1 return - end if + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! EXPAND THINNED GDS TO FULL GDS - if (idir .gt. 0) then - scan_mode = igdtmpl_thin(19) - iscale = igdtmpl_thin(10)*igdtmpl_thin(11) - if (iscale .eq. 0) iscale = 10**6 - idlat = nint(1.25*float(iscale)) - test1 = all(opt_pts .eq. npwafs) - test2 = all(opt_pts .eq. npwafs(73:1:-1)) + if(idir.gt.0) then + scan_mode=igdtmpl_thin(19) + iscale=igdtmpl_thin(10)*igdtmpl_thin(11) + if(iscale.eq.0) iscale=10**6 + idlat=nint(1.25*float(iscale)) + test1=all(opt_pts.eq.npwafs) + test2=all(opt_pts.eq.npwafs(73:1:-1)) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SOME CHECKS TO ENSURE THIS IS A WAFS GRID - if (scan_mode .eq. 64 .and. igdtmpl_thin(9) .eq. 73 .and. & - idlat .eq. igdtmpl_thin(18) .and. (test1 .or. test2)) then - igdtmpl_full = igdtmpl_thin - im = 73 - igdtmpl_full(8) = im - rlon1 = float(igdtmpl_full(13))/float(iscale) - rlon2 = float(igdtmpl_full(16))/float(iscale) - iscan = mod(igdtmpl_full(19)/128, 2) - hi = (-1.)**iscan - dlon = hi*(mod(hi*(rlon2-rlon1)-1+3600, 360.)+1)/(im-1) - igdtmpl_full(17) = nint(dlon*float(iscale)) + if(scan_mode.eq.64.and.igdtmpl_thin(9).eq.73.and. & + idlat.eq.igdtmpl_thin(18).and.(test1.or.test2)) then + igdtmpl_full=igdtmpl_thin + im=73 + igdtmpl_full(8)=im + rlon1=float(igdtmpl_full(13))/float(iscale) + rlon2=float(igdtmpl_full(16))/float(iscale) + iscan=mod(igdtmpl_full(19)/128,2) + hi=(-1.)**iscan + dlon=hi*(mod(hi*(rlon2-rlon1)-1+3600,360.)+1)/(im-1) + igdtmpl_full(17)=nint(dlon*float(iscale)) else - iret = 1 - end if + iret=1 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! CONTRACT FULL GDS TO THINNED GDS - elseif (idir .lt. 0) then - scan_mode = igdtmpl_full(19) - iscale = igdtmpl_full(10)*igdtmpl_full(11) - if (iscale .eq. 0) iscale = 10**6 - idlat = nint(1.25*float(iscale)) - idlon = idlat + elseif(idir.lt.0) then + scan_mode=igdtmpl_full(19) + iscale=igdtmpl_full(10)*igdtmpl_full(11) + if(iscale.eq.0) iscale=10**6 + idlat=nint(1.25*float(iscale)) + idlon=idlat ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SOME CHECKS TO ENSURE THIS IS A WAFS GRID - if (scan_mode .eq. 64 .and. igdtmpl_full(8) .eq. 73 .and. igdtmpl_full(9) .eq. 73 .and. & - num_opt .eq. 73 .and. idlat .eq. igdtmpl_full(18) .and. idlon .eq. igdtmpl_full(17)) then - igdtmpl_thin = igdtmpl_full - igdtmpl_thin(8) = missing - igdtmpl_thin(17) = missing - if (igdtmpl_thin(12) .eq. 0) then ! IS LATITUDE OF ROW 1 THE EQUATOR? - opt_pts = npwafs + if(scan_mode.eq.64.and.igdtmpl_full(8).eq.73.and.igdtmpl_full(9).eq.73.and. & + num_opt.eq.73.and.idlat.eq.igdtmpl_full(18).and.idlon.eq.igdtmpl_full(17)) then + igdtmpl_thin=igdtmpl_full + igdtmpl_thin(8)=missing + igdtmpl_thin(17)=missing + if(igdtmpl_thin(12).eq.0) then ! IS LATITUDE OF ROW 1 THE EQUATOR? + opt_pts=npwafs else - opt_pts = npwafs(73:1:-1) - end if + opt_pts=npwafs(73:1:-1) + endif else - iret = 1 - end if - end if + iret=1 + endif + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSFORM FIELDS - if (iret .eq. 0) then + if(iret.eq.0) then ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! EXPAND THINNED FIELDS TO FULL FIELDS - if (idir .eq. 1) then - do k = 1, km - is1 = 0 - is2 = 0 - do j = 1, igdtmpl_full(9) - im1 = opt_pts(j) - im2 = igdtmpl_full(8) - rat1 = float(im1-1)/float(im2-1) - do i = 1, im2 - x1 = (i-1)*rat1+1 - ia = int(x1) - ia = min(max(ia, 1), im1-1) - ib = ia+1 - wa = ib-x1 - wb = x1-ia - data_full(is2+i, k) = wa*data_thin(is1+ia, k)+wb*data_thin(is1+ib, k) - end do - is1 = is1+im1 - is2 = is2+im2 - end do - end do + if(idir.eq.1) then + do k=1,km + is1=0 + is2=0 + do j=1,igdtmpl_full(9) + im1=opt_pts(j) + im2=igdtmpl_full(8) + rat1=float(im1-1)/float(im2-1) + do i=1,im2 + x1=(i-1)*rat1+1 + ia=int(x1) + ia=min(max(ia,1),im1-1) + ib=ia+1 + wa=ib-x1 + wb=x1-ia + data_full(is2+i,k)=wa*data_thin(is1+ia,k)+wb*data_thin(is1+ib,k) + enddo + is1=is1+im1 + is2=is2+im2 + enddo + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! CONTRACT FULL FIELDS TO THINNED FIELDS - elseif (idir .eq. -1) then - do k = 1, km - is1 = 0 - is2 = 0 - do j = 1, igdtmpl_full(9) - im1 = opt_pts(j) - im2 = igdtmpl_full(8) - rat2 = float(im2-1)/float(im1-1) - do i = 1, im1 - x2 = (i-1)*rat2+1 - ia = int(x2) - ia = min(max(ia, 1), im2-1) - ib = ia+1 - wa = ib-x2 - wb = x2-ia - data_thin(is1+i, k) = wa*data_full(is2+ia, k)+wb*data_full(is2+ib, k) - end do - is1 = is1+im1 - is2 = is2+im2 - end do - end do - end if - end if + elseif(idir.eq.-1) then + do k=1,km + is1=0 + is2=0 + do j=1,igdtmpl_full(9) + im1=opt_pts(j) + im2=igdtmpl_full(8) + rat2=float(im2-1)/float(im1-1) + do i=1,im1 + x2=(i-1)*rat2+1 + ia=int(x2) + ia=min(max(ia,1),im2-1) + ib=ia+1 + wa=ib-x2 + wb=x2-ia + data_thin(is1+i,k)=wa*data_full(is2+ia,k)+wb*data_full(is2+ib,k) + enddo + is1=is1+im1 + is2=is2+im2 + enddo + enddo + endif + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine ipxwafs + endsubroutine ipxwafs diff --git a/src/ipxwafs2.F90 b/src/ipxwafs2.F90 index faa816c0..fefd5c17 100644 --- a/src/ipxwafs2.F90 +++ b/src/ipxwafs2.F90 @@ -86,168 +86,168 @@ !> - 1 improper grid specification !> !> @author Iredell @date 96-04-10 -subroutine ipxwafs2(idir, numpts_thin, numpts_full, km, num_opt, opt_pts, & - igdtlen, igdtmpl_thin, data_thin, ib_thin, bitmap_thin, & - igdtmpl_full, data_full, ib_full, bitmap_full, iret) +subroutine ipxwafs2(idir,numpts_thin,numpts_full,km,num_opt,opt_pts, & + igdtlen,igdtmpl_thin,data_thin,ib_thin,bitmap_thin, & + igdtmpl_full,data_full,ib_full,bitmap_full,iret) implicit none ! - integer, intent(in) :: num_opt - integer, intent(inout) :: opt_pts(num_opt) - integer, intent(in) :: idir, km, numpts_thin, numpts_full - integer, intent(in) :: igdtlen - integer, intent(inout) :: igdtmpl_thin(igdtlen) - integer, intent(inout) :: igdtmpl_full(igdtlen) - integer, intent(inout) :: ib_thin(km), ib_full(km) - integer, intent(out) :: iret + integer,intent(in) :: num_opt + integer,intent(inout) :: opt_pts(num_opt) + integer,intent(in) :: idir,km,numpts_thin,numpts_full + integer,intent(in) :: igdtlen + integer,intent(inout) :: igdtmpl_thin(igdtlen) + integer,intent(inout) :: igdtmpl_full(igdtlen) + integer,intent(inout) :: ib_thin(km),ib_full(km) + integer,intent(out) :: iret ! - logical(KIND=1), intent(inout) :: bitmap_thin(numpts_thin, km) - logical(KIND=1), intent(inout) :: bitmap_full(numpts_full, km) + logical(KIND=1),intent(inout) :: bitmap_thin(numpts_thin,km) + logical(KIND=1),intent(inout) :: bitmap_full(numpts_full,km) ! - real, intent(inout) :: data_thin(numpts_thin, km) - real, intent(inout) :: data_full(numpts_full, km) + real,intent(inout) :: data_thin(numpts_thin,km) + real,intent(inout) :: data_full(numpts_full,km) ! - integer, parameter :: missing = -1 + integer,parameter :: missing=-1 ! - integer :: scan_mode, i, j, k, idlat, idlon - integer :: ia, ib, im, im1, im2, npwafs(73) - integer :: is1, is2, iscan, iscale + integer :: scan_mode,i,j,k,idlat,idlon + integer :: ia,ib,im,im1,im2,npwafs(73) + integer :: is1,is2,iscan,iscale ! - logical :: test1, test2 + logical :: test1,test2 ! - real :: dlon, hi - real :: rat1, rat2, rlon1, rlon2 - real :: wa, wb, x1, x2 + real :: dlon,hi + real :: rat1,rat2,rlon1,rlon2 + real :: wa,wb,x1,x2 ! data npwafs/ & - 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, & - 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, & - 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, & - 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, & - 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ + 73,73,73,73,73,73,73,73,72,72,72,71,71,71,70, & + 70,69,69,68,67,67,66,65,65,64,63,62,61,60,60, & + 59,58,57,56,55,54,52,51,50,49,48,47,45,44,43, & + 42,40,39,38,36,35,33,32,30,29,28,26,25,23,22, & + 20,19,17,16,14,12,11,9,8,6,5,3,2/ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSFORM GDS - iret = 0 + iret=0 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! REG LAT/LON GRIDS HAVE 19 GDT ELEMENTS. - if (igdtlen .ne. 19 .or. numpts_thin .ne. 3447 .or. numpts_full .ne. 5329) then - iret = 1 + if(igdtlen.ne.19.or.numpts_thin.ne.3447.or.numpts_full.ne.5329) then + iret=1 return - end if + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! EXPAND THINNED GDS TO FULL GDS - if (idir .gt. 0) then - scan_mode = igdtmpl_thin(19) - iscale = igdtmpl_thin(10)*igdtmpl_thin(11) - if (iscale .eq. 0) iscale = 10**6 - idlat = nint(1.25*float(iscale)) - test1 = all(opt_pts .eq. npwafs) - test2 = all(opt_pts .eq. npwafs(73:1:-1)) + if(idir.gt.0) then + scan_mode=igdtmpl_thin(19) + iscale=igdtmpl_thin(10)*igdtmpl_thin(11) + if(iscale.eq.0) iscale=10**6 + idlat=nint(1.25*float(iscale)) + test1=all(opt_pts.eq.npwafs) + test2=all(opt_pts.eq.npwafs(73:1:-1)) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SOME CHECKS TO ENSURE THIS IS A WAFS GRID - if (scan_mode .eq. 64 .and. igdtmpl_thin(9) .eq. 73 .and. & - idlat .eq. igdtmpl_thin(18) .and. (test1 .or. test2)) then - igdtmpl_full = igdtmpl_thin - im = 73 - igdtmpl_full(8) = im - rlon1 = float(igdtmpl_full(13))/float(iscale) - rlon2 = float(igdtmpl_full(16))/float(iscale) - iscan = mod(igdtmpl_full(19)/128, 2) - hi = (-1.)**iscan - dlon = hi*(mod(hi*(rlon2-rlon1)-1+3600, 360.)+1)/(im-1) - igdtmpl_full(17) = nint(dlon*float(iscale)) + if(scan_mode.eq.64.and.igdtmpl_thin(9).eq.73.and. & + idlat.eq.igdtmpl_thin(18).and.(test1.or.test2)) then + igdtmpl_full=igdtmpl_thin + im=73 + igdtmpl_full(8)=im + rlon1=float(igdtmpl_full(13))/float(iscale) + rlon2=float(igdtmpl_full(16))/float(iscale) + iscan=mod(igdtmpl_full(19)/128,2) + hi=(-1.)**iscan + dlon=hi*(mod(hi*(rlon2-rlon1)-1+3600,360.)+1)/(im-1) + igdtmpl_full(17)=nint(dlon*float(iscale)) else - iret = 1 - end if + iret=1 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! CONTRACT FULL GDS TO THINNED GDS - elseif (idir .lt. 0) then - scan_mode = igdtmpl_full(19) - iscale = igdtmpl_full(10)*igdtmpl_full(11) - if (iscale .eq. 0) iscale = 10**6 - idlat = nint(1.25*float(iscale)) - idlon = idlat + elseif(idir.lt.0) then + scan_mode=igdtmpl_full(19) + iscale=igdtmpl_full(10)*igdtmpl_full(11) + if(iscale.eq.0) iscale=10**6 + idlat=nint(1.25*float(iscale)) + idlon=idlat ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SOME CHECKS TO ENSURE THIS IS A WAFS GRID - if (scan_mode .eq. 64 .and. igdtmpl_full(8) .eq. 73 .and. igdtmpl_full(9) .eq. 73 .and. & - num_opt .eq. 73 .and. idlat .eq. igdtmpl_full(18) .and. idlon .eq. igdtmpl_full(17)) then - igdtmpl_thin = igdtmpl_full - igdtmpl_thin(8) = missing - igdtmpl_thin(17) = missing - if (igdtmpl_thin(12) .eq. 0) then ! IS LATITUDE OF ROW 1 THE EQUATOR? - opt_pts = npwafs + if(scan_mode.eq.64.and.igdtmpl_full(8).eq.73.and.igdtmpl_full(9).eq.73.and. & + num_opt.eq.73.and.idlat.eq.igdtmpl_full(18).and.idlon.eq.igdtmpl_full(17)) then + igdtmpl_thin=igdtmpl_full + igdtmpl_thin(8)=missing + igdtmpl_thin(17)=missing + if(igdtmpl_thin(12).eq.0) then ! IS LATITUDE OF ROW 1 THE EQUATOR? + opt_pts=npwafs else - opt_pts = npwafs(73:1:-1) - end if + opt_pts=npwafs(73:1:-1) + endif else - iret = 1 - end if - end if + iret=1 + endif + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSFORM FIELDS - if (iret .eq. 0) then + if(iret.eq.0) then ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! EXPAND THINNED FIELDS TO FULL FIELDS - if (idir .eq. 1) then - do k = 1, km - is1 = 0 - is2 = 0 - ib_full(k) = 0 - do j = 1, igdtmpl_full(9) - im1 = opt_pts(j) - im2 = igdtmpl_full(8) - rat1 = float(im1-1)/float(im2-1) - do i = 1, im2 - x1 = (i-1)*rat1+1 - ia = int(x1) - ia = min(max(ia, 1), im1-1) - ib = ia+1 - wa = ib-x1 - wb = x1-ia - if (ib_thin(k) .eq. 0 .or. (bitmap_thin(is1+ia, k) .and. bitmap_thin(is1+ib, k))) then - data_full(is2+i, k) = wa*data_thin(is1+ia, k)+wb*data_thin(is1+ib, k) - bitmap_full(is2+i, k) = .true. + if(idir.eq.1) then + do k=1,km + is1=0 + is2=0 + ib_full(k)=0 + do j=1,igdtmpl_full(9) + im1=opt_pts(j) + im2=igdtmpl_full(8) + rat1=float(im1-1)/float(im2-1) + do i=1,im2 + x1=(i-1)*rat1+1 + ia=int(x1) + ia=min(max(ia,1),im1-1) + ib=ia+1 + wa=ib-x1 + wb=x1-ia + if(ib_thin(k).eq.0.or.(bitmap_thin(is1+ia,k).and.bitmap_thin(is1+ib,k))) then + data_full(is2+i,k)=wa*data_thin(is1+ia,k)+wb*data_thin(is1+ib,k) + bitmap_full(is2+i,k)=.true. else - data_full(is2+i, k) = 0.0 - bitmap_full(is2+i, k) = .false. - ib_full(k) = 1 - end if - end do - is1 = is1+im1 - is2 = is2+im2 - end do - end do + data_full(is2+i,k)=0.0 + bitmap_full(is2+i,k)=.false. + ib_full(k)=1 + endif + enddo + is1=is1+im1 + is2=is2+im2 + enddo + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! CONTRACT FULL FIELDS TO THINNED FIELDS - elseif (idir .eq. -1) then - do k = 1, km - is1 = 0 - is2 = 0 - ib_thin(k) = 0 - do j = 1, igdtmpl_full(9) - im1 = opt_pts(j) - im2 = igdtmpl_full(8) - rat2 = float(im2-1)/float(im1-1) - do i = 1, im1 - x2 = (i-1)*rat2+1 - ia = int(x2) - ia = min(max(ia, 1), im2-1) - ib = ia+1 - wa = ib-x2 - wb = x2-ia - if (ib_full(k) .eq. 0 .or. (bitmap_full(is2+ia, k) .and. bitmap_full(is2+ib, k))) then - data_thin(is1+i, k) = wa*data_full(is2+ia, k)+wb*data_full(is2+ib, k) - bitmap_thin(is1+i, k) = .true. + elseif(idir.eq.-1) then + do k=1,km + is1=0 + is2=0 + ib_thin(k)=0 + do j=1,igdtmpl_full(9) + im1=opt_pts(j) + im2=igdtmpl_full(8) + rat2=float(im2-1)/float(im1-1) + do i=1,im1 + x2=(i-1)*rat2+1 + ia=int(x2) + ia=min(max(ia,1),im2-1) + ib=ia+1 + wa=ib-x2 + wb=x2-ia + if(ib_full(k).eq.0.or.(bitmap_full(is2+ia,k).and.bitmap_full(is2+ib,k))) then + data_thin(is1+i,k)=wa*data_full(is2+ia,k)+wb*data_full(is2+ib,k) + bitmap_thin(is1+i,k)=.true. else - data_thin(is1+i, k) = 0.0 - bitmap_thin(is1+i, k) = .false. - ib_thin(k) = 1 - end if - end do - is1 = is1+im1 - is2 = is2+im2 - end do - end do - end if - end if + data_thin(is1+i,k)=0.0 + bitmap_thin(is1+i,k)=.false. + ib_thin(k)=1 + endif + enddo + is1=is1+im1 + is2=is2+im2 + enddo + enddo + endif + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -end subroutine ipxwafs2 +endsubroutine ipxwafs2 diff --git a/src/ipxwafs3.F90 b/src/ipxwafs3.F90 index ff513df9..74ef1c1c 100644 --- a/src/ipxwafs3.F90 +++ b/src/ipxwafs3.F90 @@ -85,190 +85,190 @@ !> - 1 improper grid specification !> !> @author Trojan @date 7-7-13 -subroutine ipxwafs3(idir, numpts_thin, numpts_full, km, num_opt, opt_pts, & - igdtlen, igdtmpl_thin, data_thin, ib_thin, bitmap_thin, & - igdtmpl_full, data_full, ib_full, bitmap_full, iret) +subroutine ipxwafs3(idir,numpts_thin,numpts_full,km,num_opt,opt_pts, & + igdtlen,igdtmpl_thin,data_thin,ib_thin,bitmap_thin, & + igdtmpl_full,data_full,ib_full,bitmap_full,iret) implicit none ! - integer, intent(in) :: num_opt - integer, intent(inout) :: opt_pts(num_opt) - integer, intent(in) :: idir, km, numpts_thin, numpts_full - integer, intent(in) :: igdtlen - integer, intent(inout) :: igdtmpl_thin(igdtlen) - integer, intent(inout) :: igdtmpl_full(igdtlen) - integer, intent(inout) :: ib_thin(km), ib_full(km) - integer, intent(out) :: iret + integer,intent(in) :: num_opt + integer,intent(inout) :: opt_pts(num_opt) + integer,intent(in) :: idir,km,numpts_thin,numpts_full + integer,intent(in) :: igdtlen + integer,intent(inout) :: igdtmpl_thin(igdtlen) + integer,intent(inout) :: igdtmpl_full(igdtlen) + integer,intent(inout) :: ib_thin(km),ib_full(km) + integer,intent(out) :: iret ! - logical(KIND=1), intent(inout) :: bitmap_thin(numpts_thin, km) - logical(KIND=1), intent(inout) :: bitmap_full(numpts_full, km) + logical(KIND=1),intent(inout) :: bitmap_thin(numpts_thin,km) + logical(KIND=1),intent(inout) :: bitmap_full(numpts_full,km) ! - real, intent(inout) :: data_thin(numpts_thin, km) - real, intent(inout) :: data_full(numpts_full, km) + real,intent(inout) :: data_thin(numpts_thin,km) + real,intent(inout) :: data_full(numpts_full,km) ! - integer, parameter :: missing = -1 + integer,parameter :: missing=-1 ! - integer :: scan_mode, i, j, k, idlat, idlon - integer :: ia, ib, im, im1, im2, npwafs(73) - integer :: is1, is2, iscan, iscale + integer :: scan_mode,i,j,k,idlat,idlon + integer :: ia,ib,im,im1,im2,npwafs(73) + integer :: is1,is2,iscan,iscale ! - logical :: test1, test2 + logical :: test1,test2 ! - real :: dlon, hi - real :: rat1, rat2, rlon1, rlon2 - real :: wa, wb, x1, x2 + real :: dlon,hi + real :: rat1,rat2,rlon1,rlon2 + real :: wa,wb,x1,x2 ! data npwafs/ & - 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, & - 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, & - 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, & - 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, & - 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ + 73,73,73,73,73,73,73,73,72,72,72,71,71,71,70, & + 70,69,69,68,67,67,66,65,65,64,63,62,61,60,60, & + 59,58,57,56,55,54,52,51,50,49,48,47,45,44,43, & + 42,40,39,38,36,35,33,32,30,29,28,26,25,23,22, & + 20,19,17,16,14,12,11,9,8,6,5,3,2/ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSFORM GDS - iret = 0 + iret=0 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! REG LAT/LON GRIDS HAVE 19 GDT ELEMENTS. - if (igdtlen .ne. 19 .or. numpts_thin .ne. 3447 .or. numpts_full .ne. 5329) then - iret = 1 + if(igdtlen.ne.19.or.numpts_thin.ne.3447.or.numpts_full.ne.5329) then + iret=1 return - end if + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! EXPAND THINNED GDS TO FULL GDS - if (idir .gt. 0) then - scan_mode = igdtmpl_thin(19) - iscale = igdtmpl_thin(10)*igdtmpl_thin(11) - if (iscale .eq. 0) iscale = 10**6 - idlat = nint(1.25*float(iscale)) - test1 = all(opt_pts .eq. npwafs) - test2 = all(opt_pts .eq. npwafs(73:1:-1)) + if(idir.gt.0) then + scan_mode=igdtmpl_thin(19) + iscale=igdtmpl_thin(10)*igdtmpl_thin(11) + if(iscale.eq.0) iscale=10**6 + idlat=nint(1.25*float(iscale)) + test1=all(opt_pts.eq.npwafs) + test2=all(opt_pts.eq.npwafs(73:1:-1)) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SOME CHECKS TO ENSURE THIS IS A WAFS GRID - if (scan_mode .eq. 64 .and. igdtmpl_thin(9) .eq. 73 .and. & - idlat .eq. igdtmpl_thin(18) .and. (test1 .or. test2)) then - igdtmpl_full = igdtmpl_thin - im = 73 - igdtmpl_full(8) = im - rlon1 = float(igdtmpl_full(13))/float(iscale) - rlon2 = float(igdtmpl_full(16))/float(iscale) - iscan = mod(igdtmpl_full(19)/128, 2) - hi = (-1.)**iscan - dlon = hi*(mod(hi*(rlon2-rlon1)-1+3600, 360.)+1)/(im-1) - igdtmpl_full(17) = nint(dlon*float(iscale)) + if(scan_mode.eq.64.and.igdtmpl_thin(9).eq.73.and. & + idlat.eq.igdtmpl_thin(18).and.(test1.or.test2)) then + igdtmpl_full=igdtmpl_thin + im=73 + igdtmpl_full(8)=im + rlon1=float(igdtmpl_full(13))/float(iscale) + rlon2=float(igdtmpl_full(16))/float(iscale) + iscan=mod(igdtmpl_full(19)/128,2) + hi=(-1.)**iscan + dlon=hi*(mod(hi*(rlon2-rlon1)-1+3600,360.)+1)/(im-1) + igdtmpl_full(17)=nint(dlon*float(iscale)) else - iret = 1 - end if + iret=1 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! CONTRACT FULL GDS TO THINNED GDS - elseif (idir .lt. 0) then - scan_mode = igdtmpl_full(19) - iscale = igdtmpl_full(10)*igdtmpl_full(11) - if (iscale .eq. 0) iscale = 10**6 - idlat = nint(1.25*float(iscale)) - idlon = idlat + elseif(idir.lt.0) then + scan_mode=igdtmpl_full(19) + iscale=igdtmpl_full(10)*igdtmpl_full(11) + if(iscale.eq.0) iscale=10**6 + idlat=nint(1.25*float(iscale)) + idlon=idlat ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SOME CHECKS TO ENSURE THIS IS A WAFS GRID - if (scan_mode .eq. 64 .and. igdtmpl_full(8) .eq. 73 .and. igdtmpl_full(9) .eq. 73 .and. & - num_opt .eq. 73 .and. idlat .eq. igdtmpl_full(18) .and. idlon .eq. igdtmpl_full(17)) then - igdtmpl_thin = igdtmpl_full - igdtmpl_thin(8) = missing - igdtmpl_thin(17) = missing - if (igdtmpl_thin(12) .eq. 0) then ! IS LATITUDE OF ROW 1 THE EQUATOR? - opt_pts = npwafs + if(scan_mode.eq.64.and.igdtmpl_full(8).eq.73.and.igdtmpl_full(9).eq.73.and. & + num_opt.eq.73.and.idlat.eq.igdtmpl_full(18).and.idlon.eq.igdtmpl_full(17)) then + igdtmpl_thin=igdtmpl_full + igdtmpl_thin(8)=missing + igdtmpl_thin(17)=missing + if(igdtmpl_thin(12).eq.0) then ! IS LATITUDE OF ROW 1 THE EQUATOR? + opt_pts=npwafs else - opt_pts = npwafs(73:1:-1) - end if + opt_pts=npwafs(73:1:-1) + endif else - iret = 1 - end if - end if + iret=1 + endif + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! TRANSFORM FIELDS - if (iret .eq. 0) then + if(iret.eq.0) then ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! EXPAND THINNED FIELDS TO FULL FIELDS - if (idir .eq. 1) then - do k = 1, km - is1 = 0 - is2 = 0 - ib_full(k) = 0 - do j = 1, igdtmpl_full(9) - im1 = opt_pts(j) - im2 = igdtmpl_full(8) - rat1 = float(im1-1)/float(im2-1) - do i = 1, im2 - x1 = (i-1)*rat1+1 - ia = int(x1) - ia = min(max(ia, 1), im1-1) - ib = ia+1 - wa = ib-x1 - wb = x1-ia - if (wa .ge. wb) then - if (ib_thin(k) .eq. 0 .or. bitmap_thin(is1+ia, k)) then - data_full(is2+i, k) = data_thin(is1+ia, k) - bitmap_full(is2+i, k) = .true. + if(idir.eq.1) then + do k=1,km + is1=0 + is2=0 + ib_full(k)=0 + do j=1,igdtmpl_full(9) + im1=opt_pts(j) + im2=igdtmpl_full(8) + rat1=float(im1-1)/float(im2-1) + do i=1,im2 + x1=(i-1)*rat1+1 + ia=int(x1) + ia=min(max(ia,1),im1-1) + ib=ia+1 + wa=ib-x1 + wb=x1-ia + if(wa.ge.wb) then + if(ib_thin(k).eq.0.or.bitmap_thin(is1+ia,k)) then + data_full(is2+i,k)=data_thin(is1+ia,k) + bitmap_full(is2+i,k)=.true. else - data_full(is2+i, k) = 0.0 - bitmap_full(is2+i, k) = .false. - ib_full(k) = 1 - end if + data_full(is2+i,k)=0.0 + bitmap_full(is2+i,k)=.false. + ib_full(k)=1 + endif else - if (ib_thin(k) .eq. 0 .or. bitmap_thin(is1+ib, k)) then - data_full(is2+i, k) = data_thin(is1+ib, k) - bitmap_full(is2+i, k) = .true. + if(ib_thin(k).eq.0.or.bitmap_thin(is1+ib,k)) then + data_full(is2+i,k)=data_thin(is1+ib,k) + bitmap_full(is2+i,k)=.true. else - data_full(is2+i, k) = 0.0 - bitmap_full(is2+i, k) = .false. - ib_full(k) = 1 - end if - end if - end do - is1 = is1+im1 - is2 = is2+im2 - end do - end do + data_full(is2+i,k)=0.0 + bitmap_full(is2+i,k)=.false. + ib_full(k)=1 + endif + endif + enddo + is1=is1+im1 + is2=is2+im2 + enddo + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! CONTRACT FULL FIELDS TO THINNED FIELDS - elseif (idir .eq. -1) then - do k = 1, km - is1 = 0 - is2 = 0 - ib_thin(k) = 0 - do j = 1, igdtmpl_full(9) - im1 = opt_pts(j) - im2 = igdtmpl_full(8) - rat2 = float(im2-1)/float(im1-1) - do i = 1, im1 - x2 = (i-1)*rat2+1 - ia = int(x2) - ia = min(max(ia, 1), im2-1) - ib = ia+1 - wa = ib-x2 - wb = x2-ia - if (wa .ge. wb) then - if (ib_full(k) .eq. 0 .or. bitmap_full(is2+ia, k)) then - data_thin(is1+i, k) = data_full(is2+ia, k) - bitmap_thin(is1+i, k) = .true. + elseif(idir.eq.-1) then + do k=1,km + is1=0 + is2=0 + ib_thin(k)=0 + do j=1,igdtmpl_full(9) + im1=opt_pts(j) + im2=igdtmpl_full(8) + rat2=float(im2-1)/float(im1-1) + do i=1,im1 + x2=(i-1)*rat2+1 + ia=int(x2) + ia=min(max(ia,1),im2-1) + ib=ia+1 + wa=ib-x2 + wb=x2-ia + if(wa.ge.wb) then + if(ib_full(k).eq.0.or.bitmap_full(is2+ia,k)) then + data_thin(is1+i,k)=data_full(is2+ia,k) + bitmap_thin(is1+i,k)=.true. else - data_thin(is1+i, k) = 0.0 - bitmap_thin(is1+i, k) = .false. - ib_thin(k) = 1 - end if + data_thin(is1+i,k)=0.0 + bitmap_thin(is1+i,k)=.false. + ib_thin(k)=1 + endif else - if (ib_full(k) .eq. 0 .or. bitmap_full(is2+ib, k)) then - data_thin(is1+i, k) = data_full(is2+ib, k) - bitmap_thin(is1+i, k) = .true. + if(ib_full(k).eq.0.or.bitmap_full(is2+ib,k)) then + data_thin(is1+i,k)=data_full(is2+ib,k) + bitmap_thin(is1+i,k)=.true. else - data_thin(is1+i, k) = 0.0 - bitmap_thin(is1+i, k) = .false. - ib_thin(k) = 1 - end if - end if - end do - is1 = is1+im1 - is2 = is2+im2 - end do - end do - end if - end if + data_thin(is1+i,k)=0.0 + bitmap_thin(is1+i,k)=.false. + ib_thin(k)=1 + endif + endif + enddo + is1=is1+im1 + is2=is2+im2 + enddo + enddo + endif + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -end subroutine ipxwafs3 +endsubroutine ipxwafs3 diff --git a/src/movect.F90 b/src/movect.F90 index debf5ecb..62387af2 100644 --- a/src/movect.F90 +++ b/src/movect.F90 @@ -22,47 +22,47 @@ !> (uto=crot*ufrom-srot*vfrom; vto=srot*ufrom+crot*vfrom) !> !> @author Iredell @date 96-04-10 - subroutine movect(flat, flon, tlat, tlon, crot, srot) + subroutine movect(flat,flon,tlat,tlon,crot,srot) implicit none ! - integer, parameter :: kd = selected_real_kind(15, 45) + integer,parameter :: kd=selected_real_kind(15,45) ! - real, intent(in) :: flat, flon - real, intent(in) :: tlat, tlon - real, intent(out) :: crot, srot + real,intent(in) :: flat,flon + real,intent(in) :: tlat,tlon + real,intent(out) :: crot,srot ! - real(KIND=kd), parameter :: crdlim = 0.9999999 - real(KIND=kd), parameter :: pi = 3.14159265358979 - real(KIND=kd), parameter :: dpr = 180./pi + real(KIND=kd),parameter :: crdlim=0.9999999 + real(KIND=kd),parameter :: pi=3.14159265358979 + real(KIND=kd),parameter :: dpr=180./pi ! - real(KIND=kd) :: ctlat, stlat, cflat, sflat - real(KIND=kd) :: cdlon, sdlon, crd - real(KIND=kd) :: srd2rn, str, ctr, sfr, cfr + real(KIND=kd) :: ctlat,stlat,cflat,sflat + real(KIND=kd) :: cdlon,sdlon,crd + real(KIND=kd) :: srd2rn,str,ctr,sfr,cfr ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE COSINE OF THE RADIAL DISTANCE BETWEEN THE POINTS. - ctlat = cos(tlat/dpr) - stlat = sin(tlat/dpr) - cflat = cos(flat/dpr) - sflat = sin(flat/dpr) - cdlon = cos((flon-tlon)/dpr) - sdlon = sin((flon-tlon)/dpr) - crd = stlat*sflat+ctlat*cflat*cdlon + ctlat=cos(tlat/dpr) + stlat=sin(tlat/dpr) + cflat=cos(flat/dpr) + sflat=sin(flat/dpr) + cdlon=cos((flon-tlon)/dpr) + sdlon=sin((flon-tlon)/dpr) + crd=stlat*sflat+ctlat*cflat*cdlon ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE ROTATIONS AT BOTH POINTS WITH RESPECT TO THE GREAT CIRCLE ! AND COMBINE THEM TO GIVE THE TOTAL VECTOR ROTATION PARAMETERS. - if (abs(crd) .le. crdlim) then - srd2rn = -1/(1-crd**2) - str = cflat*sdlon - ctr = cflat*stlat*cdlon-sflat*ctlat - sfr = ctlat*sdlon - cfr = ctlat*sflat*cdlon-stlat*cflat - crot = real(srd2rn*(ctr*cfr-str*sfr)) - srot = real(srd2rn*(ctr*sfr+str*cfr)) + if(abs(crd).le.crdlim) then + srd2rn=-1/(1-crd**2) + str=cflat*sdlon + ctr=cflat*stlat*cdlon-sflat*ctlat + sfr=ctlat*sdlon + cfr=ctlat*sflat*cdlon-stlat*cflat + crot=real(srd2rn*(ctr*cfr-str*sfr)) + srot=real(srd2rn*(ctr*sfr+str*cfr)) ! USE A DIFFERENT APPROXIMATION FOR NEARLY COINCIDENT POINTS. ! MOVING VECTORS TO ANTIPODAL POINTS IS AMBIGUOUS ANYWAY. else - crot = real(cdlon) - srot = real(sdlon*stlat) - end if + crot=real(cdlon) + srot=real(sdlon*stlat) + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine movect + endsubroutine movect diff --git a/src/neighbor_budget_interp_mod.F90 b/src/neighbor_budget_interp_mod.F90 index cbbe9bc5..e908a561 100644 --- a/src/neighbor_budget_interp_mod.F90 +++ b/src/neighbor_budget_interp_mod.F90 @@ -17,10 +17,10 @@ module neighbor_budget_interp_mod interface interpolate_neighbor_budget module procedure interpolate_neighbor_budget_scalar module procedure interpolate_neighbor_budget_vector - end interface interpolate_neighbor_budget + endinterface interpolate_neighbor_budget ! Smallest positive real value (use for equality comparisons) - real :: tinyreal = tiny(1.0) + real :: tinyreal=tiny(1.0) contains @@ -104,153 +104,153 @@ module neighbor_budget_interp_mod !> - 32 invalid budget method parameters !> !> @author Mark Iredell @date 96-04-10 - subroutine interpolate_neighbor_budget_scalar(ipopt, grid_in, grid_out, & - mi, mo, km, ibi, li, gi, & - no, rlat, rlon, ibo, lo, go, iret) - class(ip_grid), intent(in) :: grid_in, grid_out + subroutine interpolate_neighbor_budget_scalar(ipopt,grid_in,grid_out, & + mi,mo,km,ibi,li,gi, & + no,rlat,rlon,ibo,lo,go,iret) + class(ip_grid),intent(in) :: grid_in,grid_out - integer, intent(in) :: ibi(km), ipopt(20), km, mi, mo - integer, intent(out) :: ibo(km), iret, no + integer,intent(in) :: ibi(km),ipopt(20),km,mi,mo + integer,intent(out) :: ibo(km),iret,no ! - logical*1, intent(in) :: li(mi, km) - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(in) :: li(mi,km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: gi(mi, km) - real, intent(out) :: go(mo, km), rlat(mo), rlon(mo) + real,intent(in) :: gi(mi,km) + real,intent(out) :: go(mo,km),rlat(mo),rlon(mo) ! - real, parameter :: fill = -9999. + real,parameter :: fill=-9999. ! - integer :: ib, i1 - integer :: jb, j1, k, lb, lsw, mp, n - integer :: n11(mo), nb, nb1, nb2, nb3, nb4, nv + integer :: ib,i1 + integer :: jb,j1,k,lb,lsw,mp,n + integer :: n11(mo),nb,nb1,nb2,nb3,nb4,nv ! - real :: pmp, rlob(mo), rlab(mo) - real :: wb, wo(mo, km), xi, yi - real :: xptb(mo), yptb(mo), xpts(mo), ypts(mo) + real :: pmp,rlob(mo),rlab(mo) + real :: wb,wo(mo,km),xi,yi + real :: xptb(mo),yptb(mo),xpts(mo),ypts(mo) logical :: to_station_points - select type (grid_out) - type is (ip_station_points_grid) - to_station_points = .true. + select type(grid_out) + type is(ip_station_points_grid) + to_station_points=.true. class default - to_station_points = .false. - end select + to_station_points=.false. + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES. - iret = 0 - if (to_station_points) then - call gdswzd(grid_out, 0, mo, fill, xpts, ypts, rlon, rlat, no) - if (no .eq. 0) iret = 3 - call gdswzd(grid_in, -1, no, fill, xpts, ypts, rlon, rlat, nv) - if (nv .eq. 0) iret = 2 + iret=0 + if(to_station_points) then + call gdswzd(grid_out,0,mo,fill,xpts,ypts,rlon,rlat,no) + if(no.eq.0) iret=3 + call gdswzd(grid_in,-1,no,fill,xpts,ypts,rlon,rlat,nv) + if(nv.eq.0) iret=2 else - call gdswzd(grid_out, 0, mo, fill, xpts, ypts, rlon, rlat, no) - if (no .eq. 0) iret = 3 - end if + call gdswzd(grid_out,0,mo,fill,xpts,ypts,rlon,rlat,no) + if(no.eq.0) iret=3 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SET PARAMETERS - nb1 = ipopt(1) - if (nb1 .eq. -1) nb1 = 2 - if (iret .eq. 0 .and. nb1 .lt. 0) iret = 32 - lsw = 1 - if (ipopt(1) .eq. -1 .or. ipopt(2) .eq. -1) lsw = 0 - if (iret .eq. 0 .and. lsw .eq. 1 .and. nb1 .gt. 15) iret = 32 - mp = ipopt(3+ipopt(1)) - if (mp .eq. -1 .or. mp .eq. 0) mp = 50 - if (mp .lt. 0 .or. mp .gt. 100) iret = 32 - pmp = mp*0.01 - if (iret .eq. 0) then - nb2 = 2*nb1+1 - nb3 = nb2*nb2 - nb4 = nb3 - if (lsw .eq. 1) then - nb4 = ipopt(2) - do ib = 1, nb1 - nb4 = nb4+8*ib*ipopt(2+ib) - end do - end if + nb1=ipopt(1) + if(nb1.eq.-1) nb1=2 + if(iret.eq.0.and.nb1.lt.0) iret=32 + lsw=1 + if(ipopt(1).eq.-1.or.ipopt(2).eq.-1) lsw=0 + if(iret.eq.0.and.lsw.eq.1.and.nb1.gt.15) iret=32 + mp=ipopt(3+ipopt(1)) + if(mp.eq.-1.or.mp.eq.0) mp=50 + if(mp.lt.0.or.mp.gt.100) iret=32 + pmp=mp*0.01 + if(iret.eq.0) then + nb2=2*nb1+1 + nb3=nb2*nb2 + nb4=nb3 + if(lsw.eq.1) then + nb4=ipopt(2) + do ib=1,nb1 + nb4=nb4+8*ib*ipopt(2+ib) + enddo + endif else - nb2 = 0 - nb3 = 0 - nb4 = 0 - end if - do k = 1, km - do n = 1, no - go(n, k) = 0. - wo(n, k) = 0. - end do - end do + nb2=0 + nb3=0 + nb4=0 + endif + do k=1,km + do n=1,no + go(n,k)=0. + wo(n,k)=0. + enddo + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! LOOP OVER SAMPLE POINTS IN OUTPUT GRID BOX - do nb = 1, nb3 + do nb=1,nb3 ! LOCATE INPUT POINTS AND COMPUTE THEIR WEIGHTS - jb = (nb-1)/nb2-nb1 - ib = nb-(jb+nb1)*nb2-nb1-1 - lb = max(abs(ib), abs(jb)) - wb = 1 - if (lsw .eq. 1) wb = ipopt(2+lb) - if (abs(wb) .gt. tinyreal) then - do n = 1, no - xptb(n) = xpts(n)+ib/real(nb2) - yptb(n) = ypts(n)+jb/real(nb2) - end do - if (to_station_points) then - call gdswzd(grid_in, 1, no, fill, xptb, yptb, rlob, rlab, nv) - call gdswzd(grid_in, -1, no, fill, xptb, yptb, rlob, rlab, nv) + jb=(nb-1)/nb2-nb1 + ib=nb-(jb+nb1)*nb2-nb1-1 + lb=max(abs(ib),abs(jb)) + wb=1 + if(lsw.eq.1) wb=ipopt(2+lb) + if(abs(wb).gt.tinyreal) then + do n=1,no + xptb(n)=xpts(n)+ib/real(nb2) + yptb(n)=ypts(n)+jb/real(nb2) + enddo + if(to_station_points) then + call gdswzd(grid_in,1,no,fill,xptb,yptb,rlob,rlab,nv) + call gdswzd(grid_in,-1,no,fill,xptb,yptb,rlob,rlab,nv) else - call gdswzd(grid_out, 1, no, fill, xptb, yptb, rlob, rlab, nv) - call gdswzd(grid_in, -1, no, fill, xptb, yptb, rlob, rlab, nv) - end if - if (iret .eq. 0 .and. nv .eq. 0 .and. lb .eq. 0) iret = 2 - do n = 1, no - xi = xptb(n) - yi = yptb(n) - if (abs(xi-fill) .gt. tinyreal .and. abs(yi-fill) .gt. tinyreal) then - i1 = nint(xi) - j1 = nint(yi) - n11(n) = grid_in%field_pos(i1, j1) + call gdswzd(grid_out,1,no,fill,xptb,yptb,rlob,rlab,nv) + call gdswzd(grid_in,-1,no,fill,xptb,yptb,rlob,rlab,nv) + endif + if(iret.eq.0.and.nv.eq.0.and.lb.eq.0) iret=2 + do n=1,no + xi=xptb(n) + yi=yptb(n) + if(abs(xi-fill).gt.tinyreal.and.abs(yi-fill).gt.tinyreal) then + i1=nint(xi) + j1=nint(yi) + n11(n)=grid_in%field_pos(i1,j1) else - n11(n) = 0 - end if - end do + n11(n)=0 + endif + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE WITH OR WITHOUT BITMAPS - do k = 1, km - do n = 1, no - if (n11(n) .gt. 0) then - if (ibi(k) .eq. 0 .or. li(n11(n), k)) then - go(n, k) = go(n, k)+wb*gi(n11(n), k) - wo(n, k) = wo(n, k)+wb - end if - end if - end do - end do - end if - end do + do k=1,km + do n=1,no + if(n11(n).gt.0) then + if(ibi(k).eq.0.or.li(n11(n),k)) then + go(n,k)=go(n,k)+wb*gi(n11(n),k) + wo(n,k)=wo(n,k)+wb + endif + endif + enddo + enddo + endif + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE OUTPUT BITMAPS AND FIELDS - do k = 1, km - ibo(k) = ibi(k) - do n = 1, no - lo(n, k) = wo(n, k) .ge. pmp*nb4 - if (lo(n, k)) then - go(n, k) = go(n, k)/wo(n, k) + do k=1,km + ibo(k)=ibi(k) + do n=1,no + lo(n,k)=wo(n,k).ge.pmp*nb4 + if(lo(n,k)) then + go(n,k)=go(n,k)/wo(n,k) else - ibo(k) = 1 - go(n, k) = 0. - end if - end do - end do + ibo(k)=1 + go(n,k)=0. + endif + enddo + enddo - select type (grid_out) - type is (ip_equid_cylind_grid) - call polfixs(no, mo, km, rlat, ibo, lo, go) - end select + select type(grid_out) + type is(ip_equid_cylind_grid) + call polfixs(no,mo,km,rlat,ibo,lo,go) + endselect - end subroutine interpolate_neighbor_budget_scalar + endsubroutine interpolate_neighbor_budget_scalar !> Interpolate vector fields (budget). !> @@ -347,204 +347,204 @@ end subroutine interpolate_neighbor_budget_scalar !> - 32 invalid budget method parameters !> !> @author Mark Iredell @date 96-04-10 - subroutine interpolate_neighbor_budget_vector(ipopt, grid_in, grid_out, & - mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - class(ip_grid), intent(in) :: grid_in, grid_out + subroutine interpolate_neighbor_budget_vector(ipopt,grid_in,grid_out, & + mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + class(ip_grid),intent(in) :: grid_in,grid_out - integer, intent(in) :: ipopt(20), ibi(km) - integer, intent(in) :: km, mi, mo - integer, intent(out) :: iret, no, ibo(km) + integer,intent(in) :: ipopt(20),ibi(km) + integer,intent(in) :: km,mi,mo + integer,intent(out) :: iret,no,ibo(km) ! - logical*1, intent(in) :: li(mi, km) - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(in) :: li(mi,km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: ui(mi, km), vi(mi, km) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: uo(mo, km), vo(mo, km) - real, intent(out) :: crot(mo), srot(mo) + real,intent(in) :: ui(mi,km),vi(mi,km) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: uo(mo,km),vo(mo,km) + real,intent(out) :: crot(mo),srot(mo) ! - real, parameter :: fill = -9999. + real,parameter :: fill=-9999. ! integer :: n11(mo) - integer :: ib, jb, i1, j1 - integer :: k, lb, lsw, mp, n, nv - integer :: nb, nb1, nb2, nb3, nb4 + integer :: ib,jb,i1,j1 + integer :: k,lb,lsw,mp,n,nv + integer :: nb,nb1,nb2,nb3,nb4 ! logical :: same_grid ! - real :: c11(mo), s11(mo) - real :: cm11, sm11, pmp - real :: u11, v11, urot, vrot - real :: wb, wo(mo, km), xi, yi - real :: rlob(mo), rlab(mo) - real :: xpts(mo), ypts(mo) - real :: xptb(mo), yptb(mo) + real :: c11(mo),s11(mo) + real :: cm11,sm11,pmp + real :: u11,v11,urot,vrot + real :: wb,wo(mo,km),xi,yi + real :: rlob(mo),rlab(mo) + real :: xpts(mo),ypts(mo) + real :: xptb(mo),yptb(mo) logical :: to_station_points ! Save coeffecients between runs and only compute if grid has changed - integer, save :: mix = -1 - real, allocatable, save :: croi(:), sroi(:) - real, allocatable, save :: xpti(:), ypti(:) - real, allocatable, save :: rloi(:), rlai(:) - class(ip_grid), allocatable, save :: prev_grid_in + integer,save :: mix=-1 + real,allocatable,save :: croi(:),sroi(:) + real,allocatable,save :: xpti(:),ypti(:) + real,allocatable,save :: rloi(:),rlai(:) + class(ip_grid),allocatable,save :: prev_grid_in - select type (grid_out) - type is (ip_station_points_grid) - to_station_points = .true. + select type(grid_out) + type is(ip_station_points_grid) + to_station_points=.true. class default - to_station_points = .false. - end select + to_station_points=.false. + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES. - iret = 0 - call gdswzd(grid_out, 0, mo, fill, xpts, ypts, rlon, rlat, no, crot, srot) - if (no .eq. 0) iret = 3 - if (to_station_points) then - call gdswzd(grid_in, -1, no, fill, xpts, ypts, rlon, rlat, nv, crot, srot) - if (nv .eq. 0) iret = 2 - end if + iret=0 + call gdswzd(grid_out,0,mo,fill,xpts,ypts,rlon,rlat,no,crot,srot) + if(no.eq.0) iret=3 + if(to_station_points) then + call gdswzd(grid_in,-1,no,fill,xpts,ypts,rlon,rlat,nv,crot,srot) + if(nv.eq.0) iret=2 + endif - if (.not. allocated(prev_grid_in)) then - allocate (prev_grid_in, source=grid_in) + if(.not.allocated(prev_grid_in)) then + allocate(prev_grid_in,source=grid_in) - same_grid = .false. + same_grid=.false. else - same_grid = grid_in .eq. prev_grid_in + same_grid=grid_in.eq.prev_grid_in - if (.not. same_grid) then - deallocate (prev_grid_in) - allocate (prev_grid_in, source=grid_in) - end if - end if + if(.not.same_grid) then + deallocate(prev_grid_in) + allocate(prev_grid_in,source=grid_in) + endif + endif - if (.not. same_grid) then - if (mix .ne. mi) then - if (mix .ge. 0) deallocate (xpti, ypti, rloi, rlai, croi, sroi) - allocate (xpti(mi), ypti(mi), rloi(mi), rlai(mi), croi(mi), sroi(mi)) - mix = mi - end if - call gdswzd(grid_in, 0, mi, fill, xpti, ypti, & - rloi, rlai, nv, croi, sroi) - end if + if(.not.same_grid) then + if(mix.ne.mi) then + if(mix.ge.0) deallocate(xpti,ypti,rloi,rlai,croi,sroi) + allocate(xpti(mi),ypti(mi),rloi(mi),rlai(mi),croi(mi),sroi(mi)) + mix=mi + endif + call gdswzd(grid_in,0,mi,fill,xpti,ypti, & + rloi,rlai,nv,croi,sroi) + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SET PARAMETERS - nb1 = ipopt(1) - if (nb1 .eq. -1) nb1 = 2 - if (iret .eq. 0 .and. nb1 .lt. 0) iret = 32 - lsw = 1 - if (ipopt(1) .eq. -1 .or. ipopt(2) .eq. -1) lsw = 0 - if (iret .eq. 0 .and. lsw .eq. 1 .and. nb1 .gt. 15) iret = 32 - mp = ipopt(3+ipopt(1)) - if (mp .eq. -1 .or. mp .eq. 0) mp = 50 - if (mp .lt. 0 .or. mp .gt. 100) iret = 32 - pmp = mp*0.01 - if (iret .eq. 0) then - nb2 = 2*nb1+1 - nb3 = nb2*nb2 - nb4 = nb3 - if (lsw .eq. 1) then - nb4 = ipopt(2) - do ib = 1, nb1 - nb4 = nb4+8*ib*ipopt(2+ib) - end do - end if + nb1=ipopt(1) + if(nb1.eq.-1) nb1=2 + if(iret.eq.0.and.nb1.lt.0) iret=32 + lsw=1 + if(ipopt(1).eq.-1.or.ipopt(2).eq.-1) lsw=0 + if(iret.eq.0.and.lsw.eq.1.and.nb1.gt.15) iret=32 + mp=ipopt(3+ipopt(1)) + if(mp.eq.-1.or.mp.eq.0) mp=50 + if(mp.lt.0.or.mp.gt.100) iret=32 + pmp=mp*0.01 + if(iret.eq.0) then + nb2=2*nb1+1 + nb3=nb2*nb2 + nb4=nb3 + if(lsw.eq.1) then + nb4=ipopt(2) + do ib=1,nb1 + nb4=nb4+8*ib*ipopt(2+ib) + enddo + endif else - nb2 = 0 - nb3 = 0 - nb4 = 0 - end if - do k = 1, km - do n = 1, no - uo(n, k) = 0 - vo(n, k) = 0 - wo(n, k) = 0. - end do - end do + nb2=0 + nb3=0 + nb4=0 + endif + do k=1,km + do n=1,no + uo(n,k)=0 + vo(n,k)=0 + wo(n,k)=0. + enddo + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! LOOP OVER SAMPLE POINTS IN OUTPUT GRID BOX - do nb = 1, nb3 + do nb=1,nb3 ! LOCATE INPUT POINTS AND COMPUTE THEIR WEIGHTS AND ROTATIONS - jb = (nb-1)/nb2-nb1 - ib = nb-(jb+nb1)*nb2-nb1-1 - lb = max(abs(ib), abs(jb)) - wb = 1 - if (lsw .eq. 1) wb = ipopt(2+lb) - if (abs(wb) .gt. tinyreal) then - do n = 1, no - xptb(n) = xpts(n)+ib/real(nb2) - yptb(n) = ypts(n)+jb/real(nb2) - end do - if (to_station_points) then - call gdswzd(grid_in, 1, no, fill, xptb, yptb, rlob, rlab, nv) - call gdswzd(grid_in, -1, no, fill, xptb, yptb, rlob, rlab, nv) + jb=(nb-1)/nb2-nb1 + ib=nb-(jb+nb1)*nb2-nb1-1 + lb=max(abs(ib),abs(jb)) + wb=1 + if(lsw.eq.1) wb=ipopt(2+lb) + if(abs(wb).gt.tinyreal) then + do n=1,no + xptb(n)=xpts(n)+ib/real(nb2) + yptb(n)=ypts(n)+jb/real(nb2) + enddo + if(to_station_points) then + call gdswzd(grid_in,1,no,fill,xptb,yptb,rlob,rlab,nv) + call gdswzd(grid_in,-1,no,fill,xptb,yptb,rlob,rlab,nv) else - call gdswzd(grid_out, 1, no, fill, xptb, yptb, rlob, rlab, nv) - call gdswzd(grid_in, -1, no, fill, xptb, yptb, rlob, rlab, nv) - end if - if (iret .eq. 0 .and. nv .eq. 0 .and. lb .eq. 0) iret = 2 - do n = 1, no - xi = xptb(n) - yi = yptb(n) - if (abs(xi-fill) .gt. tinyreal .and. abs(yi-fill) .gt. tinyreal) then - i1 = nint(xi) - j1 = nint(yi) - n11(n) = grid_in%field_pos(i1, j1) - if (n11(n) .gt. 0) then - call movect(rlai(n11(n)), rloi(n11(n)), rlat(n), rlon(n), cm11, sm11) - c11(n) = cm11*croi(n11(n))+sm11*sroi(n11(n)) - s11(n) = sm11*croi(n11(n))-cm11*sroi(n11(n)) - end if + call gdswzd(grid_out,1,no,fill,xptb,yptb,rlob,rlab,nv) + call gdswzd(grid_in,-1,no,fill,xptb,yptb,rlob,rlab,nv) + endif + if(iret.eq.0.and.nv.eq.0.and.lb.eq.0) iret=2 + do n=1,no + xi=xptb(n) + yi=yptb(n) + if(abs(xi-fill).gt.tinyreal.and.abs(yi-fill).gt.tinyreal) then + i1=nint(xi) + j1=nint(yi) + n11(n)=grid_in%field_pos(i1,j1) + if(n11(n).gt.0) then + call movect(rlai(n11(n)),rloi(n11(n)),rlat(n),rlon(n),cm11,sm11) + c11(n)=cm11*croi(n11(n))+sm11*sroi(n11(n)) + s11(n)=sm11*croi(n11(n))-cm11*sroi(n11(n)) + endif else - n11(n) = 0 - end if - end do + n11(n)=0 + endif + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE WITH OR WITHOUT BITMAPS - do k = 1, km - do n = 1, no - if (n11(n) .gt. 0) then - if (ibi(k) .eq. 0 .or. li(n11(n), k)) then - u11 = c11(n)*ui(n11(n), k)-s11(n)*vi(n11(n), k) - v11 = s11(n)*ui(n11(n), k)+c11(n)*vi(n11(n), k) - uo(n, k) = uo(n, k)+wb*u11 - vo(n, k) = vo(n, k)+wb*v11 - wo(n, k) = wo(n, k)+wb - end if - end if - end do - end do - end if - end do ! NB LOOP + do k=1,km + do n=1,no + if(n11(n).gt.0) then + if(ibi(k).eq.0.or.li(n11(n),k)) then + u11=c11(n)*ui(n11(n),k)-s11(n)*vi(n11(n),k) + v11=s11(n)*ui(n11(n),k)+c11(n)*vi(n11(n),k) + uo(n,k)=uo(n,k)+wb*u11 + vo(n,k)=vo(n,k)+wb*v11 + wo(n,k)=wo(n,k)+wb + endif + endif + enddo + enddo + endif + enddo ! NB LOOP ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE OUTPUT BITMAPS AND FIELDS - do k = 1, km - ibo(k) = ibi(k) - do n = 1, no - lo(n, k) = wo(n, k) .ge. pmp*nb4 - if (lo(n, k)) then - uo(n, k) = uo(n, k)/wo(n, k) - vo(n, k) = vo(n, k)/wo(n, k) - urot = crot(n)*uo(n, k)-srot(n)*vo(n, k) - vrot = srot(n)*uo(n, k)+crot(n)*vo(n, k) - uo(n, k) = urot - vo(n, k) = vrot + do k=1,km + ibo(k)=ibi(k) + do n=1,no + lo(n,k)=wo(n,k).ge.pmp*nb4 + if(lo(n,k)) then + uo(n,k)=uo(n,k)/wo(n,k) + vo(n,k)=vo(n,k)/wo(n,k) + urot=crot(n)*uo(n,k)-srot(n)*vo(n,k) + vrot=srot(n)*uo(n,k)+crot(n)*vo(n,k) + uo(n,k)=urot + vo(n,k)=vrot else - ibo(k) = 1 - uo(n, k) = 0. - vo(n, k) = 0. - end if - end do - end do + ibo(k)=1 + uo(n,k)=0. + vo(n,k)=0. + endif + enddo + enddo - select type (grid_out) - type is (ip_equid_cylind_grid) - call polfixv(no, mo, km, rlat, rlon, ibo, lo, uo, vo) - end select + select type(grid_out) + type is(ip_equid_cylind_grid) + call polfixv(no,mo,km,rlat,rlon,ibo,lo,uo,vo) + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine interpolate_neighbor_budget_vector + endsubroutine interpolate_neighbor_budget_vector -end module neighbor_budget_interp_mod +endmodule neighbor_budget_interp_mod diff --git a/src/neighbor_interp_mod.F90 b/src/neighbor_interp_mod.F90 index a856e095..a71b2b2e 100644 --- a/src/neighbor_interp_mod.F90 +++ b/src/neighbor_interp_mod.F90 @@ -29,10 +29,10 @@ module neighbor_interp_mod interface interpolate_neighbor module procedure interpolate_neighbor_scalar module procedure interpolate_neighbor_vector - end interface interpolate_neighbor + endinterface interpolate_neighbor ! Smallest positive real value (use for equality comparisons) - real :: tinyreal = tiny(1.0) + real :: tinyreal=tiny(1.0) contains @@ -97,181 +97,181 @@ module neighbor_interp_mod !> !> @author Mark Iredell @date 96-04-10 !> @author Eric Engle @date 23-05-04 - subroutine interpolate_neighbor_scalar(ipopt, grid_in, grid_out, & - mi, mo, km, ibi, li, gi, & - no, rlat, rlon, ibo, lo, go, iret) - class(ip_grid), intent(in) :: grid_in, grid_out - integer, intent(in) :: ipopt(20) - integer, intent(in) :: mi, mo, km - integer, intent(in) :: ibi(km) - integer, intent(inout) :: no - integer, intent(out) :: iret, ibo(km) + subroutine interpolate_neighbor_scalar(ipopt,grid_in,grid_out, & + mi,mo,km,ibi,li,gi, & + no,rlat,rlon,ibo,lo,go,iret) + class(ip_grid),intent(in) :: grid_in,grid_out + integer,intent(in) :: ipopt(20) + integer,intent(in) :: mi,mo,km + integer,intent(in) :: ibi(km) + integer,intent(inout) :: no + integer,intent(out) :: iret,ibo(km) ! - logical*1, intent(in) :: li(mi, km) - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(in) :: li(mi,km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: gi(mi, km) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: go(mo, km) + real,intent(in) :: gi(mi,km) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: go(mo,km) ! - real, parameter :: fill = -9999. + real,parameter :: fill=-9999. ! - integer :: i1, j1, ixs, jxs - integer :: mspiral, n, k, nk + integer :: i1,j1,ixs,jxs + integer :: mspiral,n,k,nk integer :: nv - integer :: mx, kxs, kxt, ix, jx, nx + integer :: mx,kxs,kxt,ix,jx,nx ! - logical :: same_gridi, same_grido + logical :: same_gridi,same_grido ! - real :: xpts(mo), ypts(mo) + real :: xpts(mo),ypts(mo) logical :: to_station_points - integer, save :: nox = -1, iretx = -1 - integer, allocatable, save :: nxy(:) - real, allocatable, save :: rlatx(:), rlonx(:), xptsx(:), yptsx(:) - class(ip_grid), allocatable, save :: prev_grid_in, prev_grid_out + integer,save :: nox=-1,iretx=-1 + integer,allocatable,save :: nxy(:) + real,allocatable,save :: rlatx(:),rlonx(:),xptsx(:),yptsx(:) + class(ip_grid),allocatable,save :: prev_grid_in,prev_grid_out ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SET PARAMETERS - iret = 0 - mspiral = max(ipopt(1), 1) + iret=0 + mspiral=max(ipopt(1),1) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (.not. allocated(prev_grid_in) .or. .not. allocated(prev_grid_out)) then - allocate (prev_grid_in, source=grid_in) - allocate (prev_grid_out, source=grid_out) + if(.not.allocated(prev_grid_in).or..not.allocated(prev_grid_out)) then + allocate(prev_grid_in,source=grid_in) + allocate(prev_grid_out,source=grid_out) - same_gridi = .false. - same_grido = .false. + same_gridi=.false. + same_grido=.false. else - same_gridi = grid_in .eq. prev_grid_in - same_grido = grid_out .eq. prev_grid_out + same_gridi=grid_in.eq.prev_grid_in + same_grido=grid_out.eq.prev_grid_out - if (.not. same_gridi .or. .not. same_grido) then - deallocate (prev_grid_in) - deallocate (prev_grid_out) + if(.not.same_gridi.or..not.same_grido) then + deallocate(prev_grid_in) + deallocate(prev_grid_out) - allocate (prev_grid_in, source=grid_in) - allocate (prev_grid_out, source=grid_out) - end if - end if + allocate(prev_grid_in,source=grid_in) + allocate(prev_grid_out,source=grid_out) + endif + endif - select type (grid_out) - type is (ip_station_points_grid) - to_station_points = .true. + select type(grid_out) + type is(ip_station_points_grid) + to_station_points=.true. class default - to_station_points = .false. - end select + to_station_points=.false. + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SAVE OR SKIP WEIGHT COMPUTATION - if (iret .eq. 0 .and. (to_station_points .or. .not. same_gridi .or. .not. same_grido)) then + if(iret.eq.0.and.(to_station_points.or..not.same_gridi.or..not.same_grido)) then ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES. - call gdswzd(grid_out, 0, mo, fill, xpts, ypts, rlon, rlat, no) - if (no .eq. 0) iret = 3 + call gdswzd(grid_out,0,mo,fill,xpts,ypts,rlon,rlat,no) + if(no.eq.0) iret=3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! LOCATE INPUT POINTS - call gdswzd(grid_in, -1, no, fill, xpts, ypts, rlon, rlat, nv) - if (iret .eq. 0 .and. nv .eq. 0) iret = 2 + call gdswzd(grid_in,-1,no,fill,xpts,ypts,rlon,rlat,nv) + if(iret.eq.0.and.nv.eq.0) iret=2 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! ALLOCATE AND SAVE GRID DATA - if (nox .ne. no) then - if (nox .ge. 0) deallocate (rlatx, rlonx, xptsx, yptsx, nxy) - allocate (rlatx(no), rlonx(no), xptsx(no), yptsx(no), nxy(no)) - nox = no - end if - iretx = iret + if(nox.ne.no) then + if(nox.ge.0) deallocate(rlatx,rlonx,xptsx,yptsx,nxy) + allocate(rlatx(no),rlonx(no),xptsx(no),yptsx(no),nxy(no)) + nox=no + endif + iretx=iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE WEIGHTS - if (iret .eq. 0) then + if(iret.eq.0) then !$omp parallel do private(n) schedule(static) - do n = 1, no - rlonx(n) = rlon(n) - rlatx(n) = rlat(n) - xptsx(n) = xpts(n) - yptsx(n) = ypts(n) - if (abs(xpts(n)-fill) .gt. tinyreal .and. abs(ypts(n)-fill) .gt. tinyreal) then - nxy(n) = grid_in%field_pos(nint(xpts(n)), nint(ypts(n))) + do n=1,no + rlonx(n)=rlon(n) + rlatx(n)=rlat(n) + xptsx(n)=xpts(n) + yptsx(n)=ypts(n) + if(abs(xpts(n)-fill).gt.tinyreal.and.abs(ypts(n)-fill).gt.tinyreal) then + nxy(n)=grid_in%field_pos(nint(xpts(n)),nint(ypts(n))) else - nxy(n) = 0 - end if - end do - end if - end if + nxy(n)=0 + endif + enddo + endif + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE OVER ALL FIELDS - if (iret .eq. 0 .and. iretx .eq. 0) then - if (.not. to_station_points) then - no = nox - do n = 1, no - rlon(n) = rlonx(n) - rlat(n) = rlatx(n) - end do - end if - do n = 1, no - xpts(n) = xptsx(n) - ypts(n) = yptsx(n) - end do - !$omp parallel do private(nk, k, n, i1, j1, ixs, jxs, mx, kxs, kxt, ix, jx, nx) schedule(static) - do nk = 1, no*km - k = (nk-1)/no+1 - n = nk-no*(k-1) - go(n, k) = 0 - lo(n, k) = .false. - if (nxy(n) .gt. 0) then - if (ibi(k) .eq. 0 .or. li(nxy(n), k)) then - go(n, k) = gi(nxy(n), k) - lo(n, k) = .true. + if(iret.eq.0.and.iretx.eq.0) then + if(.not.to_station_points) then + no=nox + do n=1,no + rlon(n)=rlonx(n) + rlat(n)=rlatx(n) + enddo + endif + do n=1,no + xpts(n)=xptsx(n) + ypts(n)=yptsx(n) + enddo + !$omp parallel do private(nk,k,n,i1,j1,ixs,jxs,mx,kxs,kxt,ix,jx,nx) schedule(static) + do nk=1,no*km + k=(nk-1)/no+1 + n=nk-no*(k-1) + go(n,k)=0 + lo(n,k)=.false. + if(nxy(n).gt.0) then + if(ibi(k).eq.0.or.li(nxy(n),k)) then + go(n,k)=gi(nxy(n),k) + lo(n,k)=.true. ! SPIRAL AROUND UNTIL VALID DATA IS FOUND. - elseif (mspiral .gt. 1) then - i1 = nint(xpts(n)) - j1 = nint(ypts(n)) - ixs = int(sign(1., xpts(n)-i1)) - jxs = int(sign(1., ypts(n)-j1)) - do mx = 2, mspiral**2 - kxs = int(sqrt(4*mx-2.5)) - kxt = mx-(kxs**2/4+1) - select case (mod(kxs, 4)) - case (1) - ix = i1-ixs*(kxs/4-kxt) - jx = j1-jxs*kxs/4 - case (2) - ix = i1+ixs*(1+kxs/4) - jx = j1-jxs*(kxs/4-kxt) - case (3) - ix = i1+ixs*(1+kxs/4-kxt) - jx = j1+jxs*(1+kxs/4) + elseif(mspiral.gt.1) then + i1=nint(xpts(n)) + j1=nint(ypts(n)) + ixs=int(sign(1.,xpts(n)-i1)) + jxs=int(sign(1.,ypts(n)-j1)) + do mx=2,mspiral**2 + kxs=int(sqrt(4*mx-2.5)) + kxt=mx-(kxs**2/4+1) + select case(mod(kxs,4)) + case(1) + ix=i1-ixs*(kxs/4-kxt) + jx=j1-jxs*kxs/4 + case(2) + ix=i1+ixs*(1+kxs/4) + jx=j1-jxs*(kxs/4-kxt) + case(3) + ix=i1+ixs*(1+kxs/4-kxt) + jx=j1+jxs*(1+kxs/4) case default - ix = i1-ixs*kxs/4 - jx = j1+jxs*(kxs/4-kxt) - end select - nx = grid_in%field_pos(ix, jx) - if (nx .gt. 0) then - if (li(nx, k)) then - go(n, k) = gi(nx, k) - lo(n, k) = .true. + ix=i1-ixs*kxs/4 + jx=j1+jxs*(kxs/4-kxt) + endselect + nx=grid_in%field_pos(ix,jx) + if(nx.gt.0) then + if(li(nx,k)) then + go(n,k)=gi(nx,k) + lo(n,k)=.true. exit - end if - end if - end do - end if - end if - end do + endif + endif + enddo + endif + endif + enddo - do k = 1, km - ibo(k) = ibi(k) - if (.not. all(lo(1:no, k))) ibo(k) = 1 - end do + do k=1,km + ibo(k)=ibi(k) + if(.not.all(lo(1:no,k))) ibo(k)=1 + enddo - select type (grid_out) - type is (ip_equid_cylind_grid) - call polfixs(no, mo, km, rlat, ibo, lo, go) - end select + select type(grid_out) + type is(ip_equid_cylind_grid) + call polfixs(no,mo,km,rlat,ibo,lo,go) + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else - if (iret .eq. 0) iret = iretx - if (.not. to_station_points) no = 0 - end if + if(iret.eq.0) iret=iretx + if(.not.to_station_points) no=0 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine interpolate_neighbor_scalar + endsubroutine interpolate_neighbor_scalar !> Interpolate vector fields (neighbor). !> @@ -349,211 +349,211 @@ end subroutine interpolate_neighbor_scalar !> !> @author Mark Iredell @date 96-04-10 !> @author Eric Engle @date 23-05-04 - subroutine interpolate_neighbor_vector(ipopt, grid_in, grid_out, & - mi, mo, km, ibi, li, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) + subroutine interpolate_neighbor_vector(ipopt,grid_in,grid_out, & + mi,mo,km,ibi,li,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) - class(ip_grid), intent(in) :: grid_in, grid_out - integer, intent(in) :: ipopt(20) - integer, intent(in) :: ibi(km), mi, mo, km - integer, intent(inout) :: no - integer, intent(out) :: iret, ibo(km) + class(ip_grid),intent(in) :: grid_in,grid_out + integer,intent(in) :: ipopt(20) + integer,intent(in) :: ibi(km),mi,mo,km + integer,intent(inout) :: no + integer,intent(out) :: iret,ibo(km) ! - logical*1, intent(in) :: li(mi, km) - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(in) :: li(mi,km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: ui(mi, km), vi(mi, km) - real, intent(inout) :: crot(mo), srot(mo) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: uo(mo, km), vo(mo, km) + real,intent(in) :: ui(mi,km),vi(mi,km) + real,intent(inout) :: crot(mo),srot(mo) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: uo(mo,km),vo(mo,km) ! - real, parameter :: fill = -9999. + real,parameter :: fill=-9999. ! - integer :: i1, j1, ixs, jxs, mx - integer :: kxs, kxt, ix, jx, nx - integer :: mspiral, n, k, nk, nv + integer :: i1,j1,ixs,jxs,mx + integer :: kxs,kxt,ix,jx,nx + integer :: mspiral,n,k,nk,nv ! - logical :: same_gridi, same_grido + logical :: same_gridi,same_grido ! - real :: cx, sx, cm, sm, urot, vrot - real :: xpts(mo), ypts(mo) - real :: croi(mi), sroi(mi) - real :: xpti(mi), ypti(mi), rloi(mi), rlai(mi) + real :: cx,sx,cm,sm,urot,vrot + real :: xpts(mo),ypts(mo) + real :: croi(mi),sroi(mi) + real :: xpti(mi),ypti(mi),rloi(mi),rlai(mi) logical :: to_station_points - integer, save :: nox = -1, iretx = -1 - integer, allocatable, save :: nxy(:) + integer,save :: nox=-1,iretx=-1 + integer,allocatable,save :: nxy(:) - real, allocatable, save :: rlatx(:), rlonx(:), xptsx(:), yptsx(:) - real, allocatable, save :: crotx(:), srotx(:), cxy(:), sxy(:) - class(ip_grid), allocatable, save :: prev_grid_in, prev_grid_out + real,allocatable,save :: rlatx(:),rlonx(:),xptsx(:),yptsx(:) + real,allocatable,save :: crotx(:),srotx(:),cxy(:),sxy(:) + class(ip_grid),allocatable,save :: prev_grid_in,prev_grid_out ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SET PARAMETERS - iret = 0 - mspiral = max(ipopt(1), 1) + iret=0 + mspiral=max(ipopt(1),1) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if (.not. allocated(prev_grid_in) .or. .not. allocated(prev_grid_out)) then - allocate (prev_grid_in, source=grid_in) - allocate (prev_grid_out, source=grid_out) + if(.not.allocated(prev_grid_in).or..not.allocated(prev_grid_out)) then + allocate(prev_grid_in,source=grid_in) + allocate(prev_grid_out,source=grid_out) - same_gridi = .false. - same_grido = .false. + same_gridi=.false. + same_grido=.false. else - same_gridi = grid_in .eq. prev_grid_in - same_grido = grid_out .eq. prev_grid_out + same_gridi=grid_in.eq.prev_grid_in + same_grido=grid_out.eq.prev_grid_out - if (.not. same_gridi .or. .not. same_grido) then - deallocate (prev_grid_in) - deallocate (prev_grid_out) + if(.not.same_gridi.or..not.same_grido) then + deallocate(prev_grid_in) + deallocate(prev_grid_out) - allocate (prev_grid_in, source=grid_in) - allocate (prev_grid_out, source=grid_out) - end if - end if + allocate(prev_grid_in,source=grid_in) + allocate(prev_grid_out,source=grid_out) + endif + endif - select type (grid_out) - type is (ip_station_points_grid) - to_station_points = .true. + select type(grid_out) + type is(ip_station_points_grid) + to_station_points=.true. class default - to_station_points = .false. - end select + to_station_points=.false. + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SAVE OR SKIP WEIGHT COMPUTATION - if (iret .eq. 0 .and. (to_station_points .or. .not. same_gridi .or. .not. same_grido)) then + if(iret.eq.0.and.(to_station_points.or..not.same_gridi.or..not.same_grido)) then ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES. - call gdswzd(grid_out, 0, mo, fill, xpts, ypts, rlon, rlat, no, crot, srot) - if (no .eq. 0) iret = 3 + call gdswzd(grid_out,0,mo,fill,xpts,ypts,rlon,rlat,no,crot,srot) + if(no.eq.0) iret=3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! LOCATE INPUT POINTS - call gdswzd(grid_in, -1, no, fill, xpts, ypts, rlon, rlat, nv) - if (iret .eq. 0 .and. nv .eq. 0) iret = 2 - call gdswzd(grid_in, 0, mi, fill, xpti, ypti, rloi, rlai, nv, croi, sroi) + call gdswzd(grid_in,-1,no,fill,xpts,ypts,rlon,rlat,nv) + if(iret.eq.0.and.nv.eq.0) iret=2 + call gdswzd(grid_in,0,mi,fill,xpti,ypti,rloi,rlai,nv,croi,sroi) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! ALLOCATE AND SAVE GRID DATA - if (nox .ne. no) then - if (nox .ge. 0) deallocate (rlatx, rlonx, xptsx, yptsx, crotx, srotx, nxy, cxy, sxy) - allocate (rlatx(no), rlonx(no), xptsx(no), yptsx(no), & - crotx(no), srotx(no), nxy(no), cxy(no), sxy(no)) - nox = no - end if - iretx = iret + if(nox.ne.no) then + if(nox.ge.0) deallocate(rlatx,rlonx,xptsx,yptsx,crotx,srotx,nxy,cxy,sxy) + allocate(rlatx(no),rlonx(no),xptsx(no),yptsx(no), & + crotx(no),srotx(no),nxy(no),cxy(no),sxy(no)) + nox=no + endif + iretx=iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE WEIGHTS - if (iret .eq. 0) then - !$omp parallel do private(n, cm, sm) schedule(static) - do n = 1, no - rlonx(n) = rlon(n) - rlatx(n) = rlat(n) - xptsx(n) = xpts(n) - yptsx(n) = ypts(n) - crotx(n) = crot(n) - srotx(n) = srot(n) - if (abs(xpts(n)-fill) .gt. tinyreal .and. abs(ypts(n)-fill) .gt. tinyreal) then - nxy(n) = grid_in%field_pos(nint(xpts(n)), nint(ypts(n))) - if (nxy(n) .gt. 0) then - call movect(rlai(nxy(n)), rloi(nxy(n)), rlat(n), rlon(n), cm, sm) - cxy(n) = cm*croi(nxy(n))+sm*sroi(nxy(n)) - sxy(n) = sm*croi(nxy(n))-cm*sroi(nxy(n)) - end if + if(iret.eq.0) then + !$omp parallel do private(n,cm,sm) schedule(static) + do n=1,no + rlonx(n)=rlon(n) + rlatx(n)=rlat(n) + xptsx(n)=xpts(n) + yptsx(n)=ypts(n) + crotx(n)=crot(n) + srotx(n)=srot(n) + if(abs(xpts(n)-fill).gt.tinyreal.and.abs(ypts(n)-fill).gt.tinyreal) then + nxy(n)=grid_in%field_pos(nint(xpts(n)),nint(ypts(n))) + if(nxy(n).gt.0) then + call movect(rlai(nxy(n)),rloi(nxy(n)),rlat(n),rlon(n),cm,sm) + cxy(n)=cm*croi(nxy(n))+sm*sroi(nxy(n)) + sxy(n)=sm*croi(nxy(n))-cm*sroi(nxy(n)) + endif else - nxy(n) = 0 - end if - end do - end if - end if + nxy(n)=0 + endif + enddo + endif + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE OVER ALL FIELDS - if (iret .eq. 0 .and. iretx .eq. 0) then - if (.not. to_station_points) then - no = nox - do n = 1, no - rlon(n) = rlonx(n) - rlat(n) = rlatx(n) - crot(n) = crotx(n) - srot(n) = srotx(n) - end do - end if - do n = 1, no - xpts(n) = xptsx(n) - ypts(n) = yptsx(n) - end do + if(iret.eq.0.and.iretx.eq.0) then + if(.not.to_station_points) then + no=nox + do n=1,no + rlon(n)=rlonx(n) + rlat(n)=rlatx(n) + crot(n)=crotx(n) + srot(n)=srotx(n) + enddo + endif + do n=1,no + xpts(n)=xptsx(n) + ypts(n)=yptsx(n) + enddo !$omp parallel do & - !$omp private(nk, k, n, i1, j1, ixs, jxs, mx, kxs, kxt, ix, jx, nx) & - !$omp private(cm, sm, cx, sx, urot, vrot) schedule(static) - do nk = 1, no*km - k = (nk-1)/no+1 - n = nk-no*(k-1) - uo(n, k) = 0 - vo(n, k) = 0 - lo(n, k) = .false. - if (nxy(n) .gt. 0) then - if (ibi(k) .eq. 0 .or. li(nxy(n), k)) then - urot = cxy(n)*ui(nxy(n), k)-sxy(n)*vi(nxy(n), k) - vrot = sxy(n)*ui(nxy(n), k)+cxy(n)*vi(nxy(n), k) - uo(n, k) = crot(n)*urot-srot(n)*vrot - vo(n, k) = srot(n)*urot+crot(n)*vrot - lo(n, k) = .true. + !$omp private(nk,k,n,i1,j1,ixs,jxs,mx,kxs,kxt,ix,jx,nx) & + !$omp private(cm,sm,cx,sx,urot,vrot) schedule(static) + do nk=1,no*km + k=(nk-1)/no+1 + n=nk-no*(k-1) + uo(n,k)=0 + vo(n,k)=0 + lo(n,k)=.false. + if(nxy(n).gt.0) then + if(ibi(k).eq.0.or.li(nxy(n),k)) then + urot=cxy(n)*ui(nxy(n),k)-sxy(n)*vi(nxy(n),k) + vrot=sxy(n)*ui(nxy(n),k)+cxy(n)*vi(nxy(n),k) + uo(n,k)=crot(n)*urot-srot(n)*vrot + vo(n,k)=srot(n)*urot+crot(n)*vrot + lo(n,k)=.true. ! SPIRAL AROUND UNTIL VALID DATA IS FOUND. - elseif (mspiral .gt. 1) then - i1 = nint(xpts(n)) - j1 = nint(ypts(n)) - ixs = int(sign(1., xpts(n)-i1)) - jxs = int(sign(1., ypts(n)-j1)) - do mx = 2, mspiral**2 - kxs = int(sqrt(4*mx-2.5)) - kxt = mx-(kxs**2/4+1) - select case (mod(kxs, 4)) - case (1) - ix = i1-ixs*(kxs/4-kxt) - jx = j1-jxs*kxs/4 - case (2) - ix = i1+ixs*(1+kxs/4) - jx = j1-jxs*(kxs/4-kxt) - case (3) - ix = i1+ixs*(1+kxs/4-kxt) - jx = j1+jxs*(1+kxs/4) + elseif(mspiral.gt.1) then + i1=nint(xpts(n)) + j1=nint(ypts(n)) + ixs=int(sign(1.,xpts(n)-i1)) + jxs=int(sign(1.,ypts(n)-j1)) + do mx=2,mspiral**2 + kxs=int(sqrt(4*mx-2.5)) + kxt=mx-(kxs**2/4+1) + select case(mod(kxs,4)) + case(1) + ix=i1-ixs*(kxs/4-kxt) + jx=j1-jxs*kxs/4 + case(2) + ix=i1+ixs*(1+kxs/4) + jx=j1-jxs*(kxs/4-kxt) + case(3) + ix=i1+ixs*(1+kxs/4-kxt) + jx=j1+jxs*(1+kxs/4) case default - ix = i1-ixs*kxs/4 - jx = j1+jxs*(kxs/4-kxt) - end select - nx = grid_in%field_pos(ix, jx) - if (nx .gt. 0) then - if (li(nx, k)) then - call movect(rlai(nx), rloi(nx), rlat(n), rlon(n), cm, sm) - cx = cm*croi(nx)+sm*sroi(nx) - sx = sm*croi(nx)-cm*sroi(nx) - urot = cx*ui(nx, k)-sx*vi(nx, k) - vrot = sx*ui(nx, k)+cx*vi(nx, k) - uo(n, k) = crot(n)*urot-srot(n)*vrot - vo(n, k) = srot(n)*urot+crot(n)*vrot - lo(n, k) = .true. + ix=i1-ixs*kxs/4 + jx=j1+jxs*(kxs/4-kxt) + endselect + nx=grid_in%field_pos(ix,jx) + if(nx.gt.0) then + if(li(nx,k)) then + call movect(rlai(nx),rloi(nx),rlat(n),rlon(n),cm,sm) + cx=cm*croi(nx)+sm*sroi(nx) + sx=sm*croi(nx)-cm*sroi(nx) + urot=cx*ui(nx,k)-sx*vi(nx,k) + vrot=sx*ui(nx,k)+cx*vi(nx,k) + uo(n,k)=crot(n)*urot-srot(n)*vrot + vo(n,k)=srot(n)*urot+crot(n)*vrot + lo(n,k)=.true. exit - end if - end if - end do - end if - end if - end do - do k = 1, km - ibo(k) = ibi(k) - if (.not. all(lo(1:no, k))) ibo(k) = 1 - end do + endif + endif + enddo + endif + endif + enddo + do k=1,km + ibo(k)=ibi(k) + if(.not.all(lo(1:no,k))) ibo(k)=1 + enddo - select type (grid_out) - type is (ip_equid_cylind_grid) - call polfixv(no, mo, km, rlat, rlon, ibo, lo, uo, vo) - end select + select type(grid_out) + type is(ip_equid_cylind_grid) + call polfixv(no,mo,km,rlat,rlon,ibo,lo,uo,vo) + endselect ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - else - if (iret .eq. 0) iret = iretx - if (.not. to_station_points) no = 0 - end if + if(iret.eq.0) iret=iretx + if(.not.to_station_points) no=0 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine interpolate_neighbor_vector + endsubroutine interpolate_neighbor_vector -end module neighbor_interp_mod +endmodule neighbor_interp_mod diff --git a/src/polfix_mod.F90 b/src/polfix_mod.F90 index 69000513..7e4cf75d 100644 --- a/src/polfix_mod.F90 +++ b/src/polfix_mod.F90 @@ -8,7 +8,7 @@ module polfix_mod implicit none private - public :: polfixs, polfixv + public :: polfixs,polfixv contains @@ -26,83 +26,83 @@ module polfix_mod !> @param[out] go real (nx,km) fields !> !> @author Iredell @date 96-04-10 - subroutine polfixs(nm, nx, km, rlat, ib, lo, go) + subroutine polfixs(nm,nx,km,rlat,ib,lo,go) implicit none ! - integer, intent(in) :: nm, nx, km - integer, intent(in) :: ib(km) + integer,intent(in) :: nm,nx,km + integer,intent(in) :: ib(km) ! - logical*1, intent(inout) :: lo(nx, km) + logical*1,intent(inout) :: lo(nx,km) ! - real, intent(in) :: rlat(nm) - real, intent(inout) :: go(nx, km) + real,intent(in) :: rlat(nm) + real,intent(inout) :: go(nx,km) ! - real, parameter :: rlatnp = 89.9995 - real, parameter :: rlatsp = -rlatnp + real,parameter :: rlatnp=89.9995 + real,parameter :: rlatsp=-rlatnp ! - integer :: k, n + integer :: k,n ! - real :: wnp, gnp, tnp, wsp, gsp, tsp + real :: wnp,gnp,tnp,wsp,gsp,tsp ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - do k = 1, km - wnp = 0. - gnp = 0. - tnp = 0. - wsp = 0. - gsp = 0. - tsp = 0. + do k=1,km + wnp=0. + gnp=0. + tnp=0. + wsp=0. + gsp=0. + tsp=0. ! AVERAGE MULTIPLE POLE VALUES - !$omp parallel do private(n) reduction(+:wnp, gnp, tnp, wsp, gsp, tsp) schedule(static) - do n = 1, nm - if (rlat(n) .ge. rlatnp) then - wnp = wnp+1 - if (ib(k) .eq. 0 .or. lo(n, k)) then - gnp = gnp+go(n, k) - tnp = tnp+1 - end if - elseif (rlat(n) .le. rlatsp) then - wsp = wsp+1 - if (ib(k) .eq. 0 .or. lo(n, k)) then - gsp = gsp+go(n, k) - tsp = tsp+1 - end if - end if - end do + !$omp parallel do private(n) reduction(+:wnp,gnp,tnp,wsp,gsp,tsp) schedule(static) + do n=1,nm + if(rlat(n).ge.rlatnp) then + wnp=wnp+1 + if(ib(k).eq.0.or.lo(n,k)) then + gnp=gnp+go(n,k) + tnp=tnp+1 + endif + elseif(rlat(n).le.rlatsp) then + wsp=wsp+1 + if(ib(k).eq.0.or.lo(n,k)) then + gsp=gsp+go(n,k) + tsp=tsp+1 + endif + endif + enddo !$omp end parallel do ! DISTRIBUTE AVERAGE VALUES BACK TO MULTIPLE POLES - if (wnp .gt. 1) then - if (tnp .ge. wnp/2) then - gnp = gnp/tnp + if(wnp.gt.1) then + if(tnp.ge.wnp/2) then + gnp=gnp/tnp else - gnp = 0. - end if + gnp=0. + endif !$omp parallel do private(n) schedule(static) - do n = 1, nm - if (rlat(n) .ge. rlatnp) then - if (ib(k) .ne. 0) lo(n, k) = tnp .ge. wnp/2 - go(n, k) = gnp - end if - end do + do n=1,nm + if(rlat(n).ge.rlatnp) then + if(ib(k).ne.0) lo(n,k)=tnp.ge.wnp/2 + go(n,k)=gnp + endif + enddo !$omp end parallel do - end if - if (wsp .gt. 1) then - if (tsp .ge. wsp/2) then - gsp = gsp/tsp + endif + if(wsp.gt.1) then + if(tsp.ge.wsp/2) then + gsp=gsp/tsp else - gsp = 0. - end if + gsp=0. + endif !$omp parallel do private(n) schedule(static) - do n = 1, nm - if (rlat(n) .le. rlatsp) then - if (ib(k) .ne. 0) lo(n, k) = tsp .ge. wsp/2 - go(n, k) = gsp - end if - end do + do n=1,nm + if(rlat(n).le.rlatsp) then + if(ib(k).ne.0) lo(n,k)=tsp.ge.wsp/2 + go(n,k)=gsp + endif + enddo !$omp end parallel do - end if - end do + endif + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine polfixs + endsubroutine polfixs !> Make multiple pole vector values consistent, !> @@ -121,101 +121,101 @@ end subroutine polfixs !> @param[inout] vo real (nx,km) v-winds !> !> @author Iredell @date 96-04-10 - subroutine polfixv(nm, nx, km, rlat, rlon, ib, lo, uo, vo) + subroutine polfixv(nm,nx,km,rlat,rlon,ib,lo,uo,vo) implicit none ! - integer, intent(in) :: ib(km), nm, nx, km + integer,intent(in) :: ib(km),nm,nx,km ! - logical*1, intent(inout) :: lo(nx, km) + logical*1,intent(inout) :: lo(nx,km) ! - real, intent(in) :: rlat(nm), rlon(nm) - real, intent(inout) :: uo(nx, km), vo(nx, km) + real,intent(in) :: rlat(nm),rlon(nm) + real,intent(inout) :: uo(nx,km),vo(nx,km) ! - real, parameter :: rlatnp = 89.9995 - real, parameter :: rlatsp = -rlatnp - real, parameter :: pi = 3.14159265358979 - real, parameter :: dpr = 180./pi + real,parameter :: rlatnp=89.9995 + real,parameter :: rlatsp=-rlatnp + real,parameter :: pi=3.14159265358979 + real,parameter :: dpr=180./pi ! - integer :: k, n + integer :: k,n ! - real :: clon(nm), slon(nm) - real :: tnp, unp, vnp, wnp - real :: tsp, usp, vsp, wsp + real :: clon(nm),slon(nm) + real :: tnp,unp,vnp,wnp + real :: tsp,usp,vsp,wsp ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !$omp parallel do private(n) schedule(static) - do n = 1, nm - clon(n) = cos(rlon(n)/dpr) - slon(n) = sin(rlon(n)/dpr) - end do + do n=1,nm + clon(n)=cos(rlon(n)/dpr) + slon(n)=sin(rlon(n)/dpr) + enddo !$omp end parallel do ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - do k = 1, km - wnp = 0. - unp = 0. - vnp = 0. - tnp = 0. - wsp = 0. - usp = 0. - vsp = 0. - tsp = 0. + do k=1,km + wnp=0. + unp=0. + vnp=0. + tnp=0. + wsp=0. + usp=0. + vsp=0. + tsp=0. ! AVERAGE MULTIPLE POLE VALUES - !$omp parallel do private(n) reduction(+:wnp, unp, vnp, tnp, wsp, usp, vsp, tsp) schedule(static) - do n = 1, nm - if (rlat(n) .ge. rlatnp) then - wnp = wnp+1 - if (ib(k) .eq. 0 .or. lo(n, k)) then - unp = unp+(clon(n)*uo(n, k)-slon(n)*vo(n, k)) - vnp = vnp+(slon(n)*uo(n, k)+clon(n)*vo(n, k)) - tnp = tnp+1 - end if - elseif (rlat(n) .le. rlatsp) then - wsp = wsp+1 - if (ib(k) .eq. 0 .or. lo(n, k)) then - usp = usp+(clon(n)*uo(n, k)+slon(n)*vo(n, k)) - vsp = vsp+(-slon(n)*uo(n, k)+clon(n)*vo(n, k)) - tsp = tsp+1 - end if - end if - end do + !$omp parallel do private(n) reduction(+:wnp,unp,vnp,tnp,wsp,usp,vsp,tsp) schedule(static) + do n=1,nm + if(rlat(n).ge.rlatnp) then + wnp=wnp+1 + if(ib(k).eq.0.or.lo(n,k)) then + unp=unp+(clon(n)*uo(n,k)-slon(n)*vo(n,k)) + vnp=vnp+(slon(n)*uo(n,k)+clon(n)*vo(n,k)) + tnp=tnp+1 + endif + elseif(rlat(n).le.rlatsp) then + wsp=wsp+1 + if(ib(k).eq.0.or.lo(n,k)) then + usp=usp+(clon(n)*uo(n,k)+slon(n)*vo(n,k)) + vsp=vsp+(-slon(n)*uo(n,k)+clon(n)*vo(n,k)) + tsp=tsp+1 + endif + endif + enddo !$omp end parallel do ! DISTRIBUTE AVERAGE VALUES BACK TO MULTIPLE POLES - if (wnp .gt. 1) then - if (tnp .ge. wnp/2) then - unp = unp/tnp - vnp = vnp/tnp + if(wnp.gt.1) then + if(tnp.ge.wnp/2) then + unp=unp/tnp + vnp=vnp/tnp else - unp = 0. - vnp = 0. - end if + unp=0. + vnp=0. + endif !$omp parallel do private(n) schedule(static) - do n = 1, nm - if (rlat(n) .ge. rlatnp) then - if (ib(k) .ne. 0) lo(n, k) = tnp .ge. wnp/2 - uo(n, k) = clon(n)*unp+slon(n)*vnp - vo(n, k) = -slon(n)*unp+clon(n)*vnp - end if - end do + do n=1,nm + if(rlat(n).ge.rlatnp) then + if(ib(k).ne.0) lo(n,k)=tnp.ge.wnp/2 + uo(n,k)=clon(n)*unp+slon(n)*vnp + vo(n,k)=-slon(n)*unp+clon(n)*vnp + endif + enddo !$omp end parallel do - end if - if (wsp .gt. 1) then - if (tsp .ge. wsp/2) then - usp = usp/wsp - vsp = vsp/wsp + endif + if(wsp.gt.1) then + if(tsp.ge.wsp/2) then + usp=usp/wsp + vsp=vsp/wsp else - usp = 0. - vsp = 0. - end if + usp=0. + vsp=0. + endif !$omp parallel do private(n) schedule(static) - do n = 1, nm - if (rlat(n) .le. rlatsp) then - if (ib(k) .ne. 0) lo(n, k) = tsp .ge. wsp/2 - uo(n, k) = clon(n)*usp-slon(n)*vsp - vo(n, k) = slon(n)*usp+clon(n)*vsp - end if - end do + do n=1,nm + if(rlat(n).le.rlatsp) then + if(ib(k).ne.0) lo(n,k)=tsp.ge.wsp/2 + uo(n,k)=clon(n)*usp-slon(n)*vsp + vo(n,k)=slon(n)*usp+clon(n)*vsp + endif + enddo !$omp end parallel do - end if - end do + endif + enddo ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine polfixv -end module polfix_mod + endsubroutine polfixv +endmodule polfix_mod diff --git a/src/spectral_interp_mod.F90 b/src/spectral_interp_mod.F90 index 1fc91e9a..aff17371 100644 --- a/src/spectral_interp_mod.F90 +++ b/src/spectral_interp_mod.F90 @@ -20,17 +20,17 @@ module spectral_interp_mod interface interpolate_spectral module procedure interpolate_spectral_scalar module procedure interpolate_spectral_vector - end interface interpolate_spectral + endinterface interpolate_spectral interface polates4 module procedure polates4_grib1 module procedure polates4_grib2 - end interface polates4 + endinterface polates4 interface polatev4 module procedure polatev4_grib1 module procedure polatev4_grib2 - end interface polatev4 + endinterface polatev4 contains @@ -58,37 +58,37 @@ module spectral_interp_mod !> @param[out] IRET return code. 0/non-0 - successful/not successful. !> !! @author Mark Iredell @date 96-04-10 - subroutine interpolate_spectral_scalar(ipopt, grid_in, grid_out, & - mi, mo, km, ibi, gi, & - no, rlat, rlon, ibo, lo, go, iret) - integer, intent(in) :: ipopt(20) - class(ip_grid), intent(in) :: grid_in, grid_out - integer, intent(in) :: mi, mo - integer, intent(in) :: ibi(km), km - integer, intent(out) :: ibo(km), iret, no + subroutine interpolate_spectral_scalar(ipopt,grid_in,grid_out, & + mi,mo,km,ibi,gi, & + no,rlat,rlon,ibo,lo,go,iret) + integer,intent(in) :: ipopt(20) + class(ip_grid),intent(in) :: grid_in,grid_out + integer,intent(in) :: mi,mo + integer,intent(in) :: ibi(km),km + integer,intent(out) :: ibo(km),iret,no ! - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: gi(mi, km) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: go(mo, km) + real,intent(in) :: gi(mi,km) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: go(mo,km) - select type (desc_in => grid_in%descriptor) - type is (grib1_descriptor) - select type (desc_out => grid_out%descriptor) - type is (grib1_descriptor) - call polates4(ipopt, desc_in%gds, desc_out%gds, mi, mo, km, ibi, gi, no, rlat, rlon, ibo, lo, go, iret) - end select + select type(desc_in=>grid_in%descriptor) + type is(grib1_descriptor) + select type(desc_out=>grid_out%descriptor) + type is(grib1_descriptor) + call polates4(ipopt,desc_in%gds,desc_out%gds,mi,mo,km,ibi,gi,no,rlat,rlon,ibo,lo,go,iret) + endselect - type is (grib2_descriptor) - select type (desc_out => grid_out%descriptor) - type is (grib2_descriptor) - call polates4(ipopt, desc_in%gdt_num, desc_in%gdt_tmpl, desc_in%gdt_len, & - desc_out%gdt_num, desc_out%gdt_tmpl, desc_out%gdt_len, & - mi, mo, km, ibi, gi, no, rlat, rlon, ibo, lo, go, iret) - end select - end select - end subroutine interpolate_spectral_scalar + type is(grib2_descriptor) + select type(desc_out=>grid_out%descriptor) + type is(grib2_descriptor) + call polates4(ipopt,desc_in%gdt_num,desc_in%gdt_tmpl,desc_in%gdt_len, & + desc_out%gdt_num,desc_out%gdt_tmpl,desc_out%gdt_len, & + mi,mo,km,ibi,gi,no,rlat,rlon,ibo,lo,go,iret) + endselect + endselect + endsubroutine interpolate_spectral_scalar !> Interpolate spectral vector. !> @@ -118,40 +118,40 @@ end subroutine interpolate_spectral_scalar !> @param IRET return code. 0/non-0 - successful/not successful. !> !! @author Mark Iredell @date 96-04-10 - subroutine interpolate_spectral_vector(ipopt, grid_in, grid_out, & - mi, mo, km, ibi, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - class(ip_grid), intent(in) :: grid_in, grid_out - integer, intent(in) :: ipopt(20), ibi(km) - integer, intent(in) :: km, mi, mo - integer, intent(out) :: iret, ibo(km), no + subroutine interpolate_spectral_vector(ipopt,grid_in,grid_out, & + mi,mo,km,ibi,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + class(ip_grid),intent(in) :: grid_in,grid_out + integer,intent(in) :: ipopt(20),ibi(km) + integer,intent(in) :: km,mi,mo + integer,intent(out) :: iret,ibo(km),no ! - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: ui(mi, km), vi(mi, km) - real, intent(out) :: uo(mo, km), vo(mo, km) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: crot(mo), srot(mo) + real,intent(in) :: ui(mi,km),vi(mi,km) + real,intent(out) :: uo(mo,km),vo(mo,km) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: crot(mo),srot(mo) - select type (desc_in => grid_in%descriptor) - type is (grib1_descriptor) - select type (desc_out => grid_out%descriptor) - type is (grib1_descriptor) - call polatev4_grib1(ipopt, desc_in%gds, desc_out%gds, mi, mo, km, ibi, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - end select + select type(desc_in=>grid_in%descriptor) + type is(grib1_descriptor) + select type(desc_out=>grid_out%descriptor) + type is(grib1_descriptor) + call polatev4_grib1(ipopt,desc_in%gds,desc_out%gds,mi,mo,km,ibi,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + endselect - type is (grib2_descriptor) - select type (desc_out => grid_out%descriptor) - type is (grib2_descriptor) - call polatev4(ipopt, desc_in%gdt_num, desc_in%gdt_tmpl, desc_in%gdt_len, & - desc_out%gdt_num, desc_out%gdt_tmpl, desc_out%gdt_len, & - mi, mo, km, ibi, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - end select - end select + type is(grib2_descriptor) + select type(desc_out=>grid_out%descriptor) + type is(grib2_descriptor) + call polatev4(ipopt,desc_in%gdt_num,desc_in%gdt_tmpl,desc_in%gdt_len, & + desc_out%gdt_num,desc_out%gdt_tmpl,desc_out%gdt_len, & + mi,mo,km,ibi,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + endselect + endselect - end subroutine interpolate_spectral_vector + endsubroutine interpolate_spectral_vector !> Interpolate scalar fields (spectral). !> @@ -249,241 +249,241 @@ end subroutine interpolate_spectral_vector !> - 42 invalid spectral method parameters !> !>! @author Mark Iredell @date 96-04-10 - subroutine polates4_grib2(ipopt, igdtnumi, igdtmpli, igdtleni, & - igdtnumo, igdtmplo, igdtleno, & - mi, mo, km, ibi, gi, & - no, rlat, rlon, ibo, lo, go, iret) - integer, intent(in) :: igdtnumi, igdtleni - integer, intent(in) :: igdtmpli(igdtleni) - integer, intent(in) :: igdtnumo, igdtleno - integer, intent(in) :: igdtmplo(igdtleno) - integer, intent(in) :: ipopt(20) - integer, intent(in) :: mi, mo - integer, intent(in) :: ibi(km), km - integer, intent(out) :: ibo(km), iret, no + subroutine polates4_grib2(ipopt,igdtnumi,igdtmpli,igdtleni, & + igdtnumo,igdtmplo,igdtleno, & + mi,mo,km,ibi,gi, & + no,rlat,rlon,ibo,lo,go,iret) + integer,intent(in) :: igdtnumi,igdtleni + integer,intent(in) :: igdtmpli(igdtleni) + integer,intent(in) :: igdtnumo,igdtleno + integer,intent(in) :: igdtmplo(igdtleno) + integer,intent(in) :: ipopt(20) + integer,intent(in) :: mi,mo + integer,intent(in) :: ibi(km),km + integer,intent(out) :: ibo(km),iret,no ! - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: gi(mi, km) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: go(mo, km) + real,intent(in) :: gi(mi,km) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: go(mo,km) ! - real, parameter :: fill = -9999. - real, parameter :: pi = 3.14159265358979 - real, parameter :: dpr = 180./pi + real,parameter :: fill=-9999. + real,parameter :: pi=3.14159265358979 + real,parameter :: dpr=180./pi ! - integer :: idrti, idrto, ig, jg, im, jm - integer :: igo, jgo, imo, jmo - integer :: iscan, jscan, nscan - integer :: iscano, jscano, nscano - integer :: iskipi, jskipi, iscale - integer :: imaxi, jmaxi, ispec - integer :: ip, iprime, iproj, iromb, k - integer :: maxwv, n, ni, nj, nps + integer :: idrti,idrto,ig,jg,im,jm + integer :: igo,jgo,imo,jmo + integer :: iscan,jscan,nscan + integer :: iscano,jscano,nscano + integer :: iskipi,jskipi,iscale + integer :: imaxi,jmaxi,ispec + integer :: ip,iprime,iproj,iromb,k + integer :: maxwv,n,ni,nj,nps ! - real :: de, dr, dy - real :: dlat, dlon, dlato, dlono - real :: go2(mo, km), h, hi, hj - real :: orient, slat, rerth, e2 - real :: rlat1, rlon1, rlat2, rlon2, rlati - real :: xmesh, xp, yp - real :: xpts(mo), ypts(mo) + real :: de,dr,dy + real :: dlat,dlon,dlato,dlono + real :: go2(mo,km),h,hi,hj + real :: orient,slat,rerth,e2 + real :: rlat1,rlon1,rlat2,rlon2,rlati + real :: xmesh,xp,yp + real :: xpts(mo),ypts(mo) - type(grib2_descriptor) :: desc_in, desc_out - class(ip_grid), allocatable :: grid_in, grid_out + type(grib2_descriptor) :: desc_in,desc_out + class(ip_grid),allocatable :: grid_in,grid_out - desc_in = init_descriptor(igdtnumi, igdtleni, igdtmpli) - desc_out = init_descriptor(igdtnumo, igdtleno, igdtmplo) + desc_in=init_descriptor(igdtnumi,igdtleni,igdtmpli) + desc_out=init_descriptor(igdtnumo,igdtleno,igdtmplo) - call init_grid(grid_in, desc_in) - call init_grid(grid_out, desc_out) + call init_grid(grid_in,desc_in) + call init_grid(grid_out,desc_out) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES. - iret = 0 - if (igdtnumo .ge. 0) then + iret=0 + if(igdtnumo.ge.0) then !CALL GDSWZD(IGDTNUMO,IGDTMPLO,IGDTLENO, 0,MO,FILL,XPTS,YPTS,RLON,RLAT,NO) - call gdswzd(grid_out, 0, mo, fill, xpts, ypts, rlon, rlat, no) - if (no .eq. 0) iret = 3 - end if + call gdswzd(grid_out,0,mo,fill,xpts,ypts,rlon,rlat,no) + if(no.eq.0) iret=3 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! AFFIRM APPROPRIATE INPUT GRID ! LAT/LON OR GAUSSIAN ! NO BITMAPS ! FULL ZONAL COVERAGE ! FULL MERIDIONAL COVERAGE - idrti = igdtnumi - if (idrti .eq. 40) idrti = 4 - if (idrti .eq. 0 .or. idrti .eq. 4) then - im = igdtmpli(8) - jm = igdtmpli(9) - iscale = igdtmpli(10)*igdtmpli(11) - if (iscale .eq. 0) iscale = 10**6 - rlon1 = float(igdtmpli(13))/float(iscale) - rlon2 = float(igdtmpli(16))/float(iscale) - iscan = mod(igdtmpli(19)/128, 2) - jscan = mod(igdtmpli(19)/64, 2) - nscan = mod(igdtmpli(19)/32, 2) + idrti=igdtnumi + if(idrti.eq.40) idrti=4 + if(idrti.eq.0.or.idrti.eq.4) then + im=igdtmpli(8) + jm=igdtmpli(9) + iscale=igdtmpli(10)*igdtmpli(11) + if(iscale.eq.0) iscale=10**6 + rlon1=float(igdtmpli(13))/float(iscale) + rlon2=float(igdtmpli(16))/float(iscale) + iscan=mod(igdtmpli(19)/128,2) + jscan=mod(igdtmpli(19)/64,2) + nscan=mod(igdtmpli(19)/32,2) else - iret = 41 - end if - do k = 1, km - if (ibi(k) .ne. 0) iret = 41 - end do - if (iret .eq. 0) then - if (iscan .eq. 0) then - dlon = (mod(rlon2-rlon1-1+3600, 360.)+1)/(im-1) + iret=41 + endif + do k=1,km + if(ibi(k).ne.0) iret=41 + enddo + if(iret.eq.0) then + if(iscan.eq.0) then + dlon=(mod(rlon2-rlon1-1+3600,360.)+1)/(im-1) else - dlon = -(mod(rlon1-rlon2-1+3600, 360.)+1)/(im-1) - end if - ig = nint(360/abs(dlon)) - iprime = 1+mod(-nint(rlon1/dlon)+ig, ig) - imaxi = ig - jmaxi = jm - if (mod(ig, 2) .ne. 0 .or. im .lt. ig) iret = 41 - end if - if (iret .eq. 0 .and. idrti .eq. 0) then - iscale = igdtmpli(10)*igdtmpli(11) - if (iscale .eq. 0) iscale = 10**6 - rlat1 = float(igdtmpli(12))/float(iscale) - rlat2 = float(igdtmpli(15))/float(iscale) - dlat = (rlat2-rlat1)/(jm-1) - jg = nint(180/abs(dlat)) - if (jm .eq. jg) idrti = 256 - if (jm .ne. jg .and. jm .ne. jg+1) iret = 41 - elseif (iret .eq. 0 .and. idrti .eq. 4) then - jg = igdtmpli(18)*2 - if (jm .ne. jg) iret = 41 - end if + dlon=-(mod(rlon1-rlon2-1+3600,360.)+1)/(im-1) + endif + ig=nint(360/abs(dlon)) + iprime=1+mod(-nint(rlon1/dlon)+ig,ig) + imaxi=ig + jmaxi=jm + if(mod(ig,2).ne.0.or.im.lt.ig) iret=41 + endif + if(iret.eq.0.and.idrti.eq.0) then + iscale=igdtmpli(10)*igdtmpli(11) + if(iscale.eq.0) iscale=10**6 + rlat1=float(igdtmpli(12))/float(iscale) + rlat2=float(igdtmpli(15))/float(iscale) + dlat=(rlat2-rlat1)/(jm-1) + jg=nint(180/abs(dlat)) + if(jm.eq.jg) idrti=256 + if(jm.ne.jg.and.jm.ne.jg+1) iret=41 + elseif(iret.eq.0.and.idrti.eq.4) then + jg=igdtmpli(18)*2 + if(jm.ne.jg) iret=41 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SET PARAMETERS - if (iret .eq. 0) then - iromb = ipopt(1) - maxwv = ipopt(2) - if (maxwv .eq. -1) then - if (iromb .eq. 0 .and. idrti .eq. 4) maxwv = (jmaxi-1) - if (iromb .eq. 1 .and. idrti .eq. 4) maxwv = (jmaxi-1)/2 - if (iromb .eq. 0 .and. idrti .eq. 0) maxwv = (jmaxi-3)/2 - if (iromb .eq. 1 .and. idrti .eq. 0) maxwv = (jmaxi-3)/4 - if (iromb .eq. 0 .and. idrti .eq. 256) maxwv = (jmaxi-1)/2 - if (iromb .eq. 1 .and. idrti .eq. 256) maxwv = (jmaxi-1)/4 - end if - if ((iromb .ne. 0 .and. iromb .ne. 1) .or. maxwv .lt. 0) iret = 42 - end if + if(iret.eq.0) then + iromb=ipopt(1) + maxwv=ipopt(2) + if(maxwv.eq.-1) then + if(iromb.eq.0.and.idrti.eq.4) maxwv=(jmaxi-1) + if(iromb.eq.1.and.idrti.eq.4) maxwv=(jmaxi-1)/2 + if(iromb.eq.0.and.idrti.eq.0) maxwv=(jmaxi-3)/2 + if(iromb.eq.1.and.idrti.eq.0) maxwv=(jmaxi-3)/4 + if(iromb.eq.0.and.idrti.eq.256) maxwv=(jmaxi-1)/2 + if(iromb.eq.1.and.idrti.eq.256) maxwv=(jmaxi-1)/4 + endif + if((iromb.ne.0.and.iromb.ne.1).or.maxwv.lt.0) iret=42 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE - if (iret .eq. 0) then - if (nscan .eq. 0) then - iskipi = 1 - jskipi = im + if(iret.eq.0) then + if(nscan.eq.0) then + iskipi=1 + jskipi=im else - iskipi = jm - jskipi = 1 - end if - if (iscan .eq. 1) iskipi = -iskipi - if (jscan .eq. 0) jskipi = -jskipi - ispec = 0 + iskipi=jm + jskipi=1 + endif + if(iscan.eq.1) iskipi=-iskipi + if(jscan.eq.0) jskipi=-jskipi + ispec=0 ! SPECIAL CASE OF GLOBAL CYLINDRICAL GRID - if ((igdtnumo .eq. 0 .or. igdtnumo .eq. 40) .and. & - mod(igdtmplo(8), 2) .eq. 0 .and. igdtmplo(13) .eq. 0 .and. igdtmplo(19) .eq. 0) then - idrto = igdtnumo - if (idrto .eq. 40) idrto = 4 - imo = igdtmplo(8) - jmo = igdtmplo(9) - iscale = igdtmplo(10)*igdtmplo(11) - if (iscale .eq. 0) iscale = 10**6 - rlon2 = float(igdtmplo(16))/float(iscale) - dlono = (mod(rlon2-1+3600, 360.)+1)/(imo-1) - igo = nint(360/abs(dlono)) - if (imo .eq. igo .and. idrto .eq. 0) then - rlat1 = float(igdtmplo(12))/float(iscale) - rlat2 = float(igdtmplo(15))/float(iscale) - dlat = (rlat2-rlat1)/(jmo-1) - jgo = nint(180/abs(dlat)) - if (jmo .eq. jgo) idrto = 256 - if (jmo .eq. jgo .or. jmo .eq. jgo+1) ispec = 1 - elseif (imo .eq. igo .and. idrto .eq. 4) then - jgo = igdtmplo(18)*2 - if (jmo .eq. jgo) ispec = 1 - end if - if (ispec .eq. 1) then - call sptrun(iromb, maxwv, idrti, imaxi, jmaxi, idrto, imo, jmo, & - km, iprime, iskipi, jskipi, mi, 0, 0, mo, 0, gi, go) - end if + if((igdtnumo.eq.0.or.igdtnumo.eq.40).and. & + mod(igdtmplo(8),2).eq.0.and.igdtmplo(13).eq.0.and.igdtmplo(19).eq.0) then + idrto=igdtnumo + if(idrto.eq.40) idrto=4 + imo=igdtmplo(8) + jmo=igdtmplo(9) + iscale=igdtmplo(10)*igdtmplo(11) + if(iscale.eq.0) iscale=10**6 + rlon2=float(igdtmplo(16))/float(iscale) + dlono=(mod(rlon2-1+3600,360.)+1)/(imo-1) + igo=nint(360/abs(dlono)) + if(imo.eq.igo.and.idrto.eq.0) then + rlat1=float(igdtmplo(12))/float(iscale) + rlat2=float(igdtmplo(15))/float(iscale) + dlat=(rlat2-rlat1)/(jmo-1) + jgo=nint(180/abs(dlat)) + if(jmo.eq.jgo) idrto=256 + if(jmo.eq.jgo.or.jmo.eq.jgo+1) ispec=1 + elseif(imo.eq.igo.and.idrto.eq.4) then + jgo=igdtmplo(18)*2 + if(jmo.eq.jgo) ispec=1 + endif + if(ispec.eq.1) then + call sptrun(iromb,maxwv,idrti,imaxi,jmaxi,idrto,imo,jmo, & + km,iprime,iskipi,jskipi,mi,0,0,mo,0,gi,go) + endif ! SPECIAL CASE OF POLAR STEREOGRAPHIC GRID - elseif (igdtnumo .eq. 20 .and. & - igdtmplo(8) .eq. igdtmplo(9) .and. mod(igdtmplo(8), 2) .eq. 1 .and. & - igdtmplo(15) .eq. igdtmplo(16) .and. igdtmplo(18) .eq. 64) then - nps = igdtmplo(8) - rlat1 = float(igdtmplo(10))*1.e-6 - rlon1 = float(igdtmplo(11))*1.e-6 - orient = float(igdtmplo(14))*1.e-6 - xmesh = float(igdtmplo(15))*1.e-3 - iproj = mod(igdtmplo(17)/128, 2) - ip = (nps+1)/2 - h = (-1.)**iproj - slat = float(abs(igdtmplo(13)))*1.e-6 - call earth_radius(igdtmplo, igdtleno, rerth, e2) - de = (1.+sin(slat/dpr))*rerth - dr = de*cos(rlat1/dpr)/(1+h*sin(rlat1/dpr)) - xp = 1-h*sin((rlon1-orient)/dpr)*dr/xmesh - yp = 1+cos((rlon1-orient)/dpr)*dr/xmesh - if (nint(xp) .eq. ip .and. nint(yp) .eq. ip) then - if (iproj .eq. 0) then - call sptruns(iromb, maxwv, idrti, imaxi, jmaxi, km, nps, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, & - slat, xmesh, orient, gi, go, go2) + elseif(igdtnumo.eq.20.and. & + igdtmplo(8).eq.igdtmplo(9).and.mod(igdtmplo(8),2).eq.1.and. & + igdtmplo(15).eq.igdtmplo(16).and.igdtmplo(18).eq.64) then + nps=igdtmplo(8) + rlat1=float(igdtmplo(10))*1.e-6 + rlon1=float(igdtmplo(11))*1.e-6 + orient=float(igdtmplo(14))*1.e-6 + xmesh=float(igdtmplo(15))*1.e-3 + iproj=mod(igdtmplo(17)/128,2) + ip=(nps+1)/2 + h=(-1.)**iproj + slat=float(abs(igdtmplo(13)))*1.e-6 + call earth_radius(igdtmplo,igdtleno,rerth,e2) + de=(1.+sin(slat/dpr))*rerth + dr=de*cos(rlat1/dpr)/(1+h*sin(rlat1/dpr)) + xp=1-h*sin((rlon1-orient)/dpr)*dr/xmesh + yp=1+cos((rlon1-orient)/dpr)*dr/xmesh + if(nint(xp).eq.ip.and.nint(yp).eq.ip) then + if(iproj.eq.0) then + call sptruns(iromb,maxwv,idrti,imaxi,jmaxi,km,nps, & + iprime,iskipi,jskipi,mi,mo,0,0,0, & + slat,xmesh,orient,gi,go,go2) else - call sptruns(iromb, maxwv, idrti, imaxi, jmaxi, km, nps, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, & - slat, xmesh, orient, gi, go2, go) - end if - ispec = 1 - end if + call sptruns(iromb,maxwv,idrti,imaxi,jmaxi,km,nps, & + iprime,iskipi,jskipi,mi,mo,0,0,0, & + slat,xmesh,orient,gi,go2,go) + endif + ispec=1 + endif ! SPECIAL CASE OF MERCATOR GRID - elseif (igdtnumo .eq. 10) then - ni = igdtmplo(8) - nj = igdtmplo(9) - rlat1 = float(igdtmplo(10))*1.0e-6 - rlon1 = float(igdtmplo(11))*1.0e-6 - rlon2 = float(igdtmplo(15))*1.0e-6 - rlati = float(igdtmplo(13))*1.0e-6 - iscano = mod(igdtmplo(16)/128, 2) - jscano = mod(igdtmplo(16)/64, 2) - nscano = mod(igdtmplo(16)/32, 2) - dy = float(igdtmplo(19))*1.0e-3 - hi = (-1.)**iscano - hj = (-1.)**(1-jscano) - call earth_radius(igdtmplo, igdtleno, rerth, e2) - dlono = hi*(mod(hi*(rlon2-rlon1)-1+3600, 360.)+1)/(ni-1) - dlato = hj*dy/(rerth*cos(rlati/dpr))*dpr - if (nscano .eq. 0) then - call sptrunm(iromb, maxwv, idrti, imaxi, jmaxi, km, ni, nj, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, & - rlat1, rlon1, dlato, dlono, gi, go) - ispec = 1 - end if - end if + elseif(igdtnumo.eq.10) then + ni=igdtmplo(8) + nj=igdtmplo(9) + rlat1=float(igdtmplo(10))*1.0e-6 + rlon1=float(igdtmplo(11))*1.0e-6 + rlon2=float(igdtmplo(15))*1.0e-6 + rlati=float(igdtmplo(13))*1.0e-6 + iscano=mod(igdtmplo(16)/128,2) + jscano=mod(igdtmplo(16)/64,2) + nscano=mod(igdtmplo(16)/32,2) + dy=float(igdtmplo(19))*1.0e-3 + hi=(-1.)**iscano + hj=(-1.)**(1-jscano) + call earth_radius(igdtmplo,igdtleno,rerth,e2) + dlono=hi*(mod(hi*(rlon2-rlon1)-1+3600,360.)+1)/(ni-1) + dlato=hj*dy/(rerth*cos(rlati/dpr))*dpr + if(nscano.eq.0) then + call sptrunm(iromb,maxwv,idrti,imaxi,jmaxi,km,ni,nj, & + iprime,iskipi,jskipi,mi,mo,0,0,0, & + rlat1,rlon1,dlato,dlono,gi,go) + ispec=1 + endif + endif ! GENERAL SLOW CASE - if (ispec .eq. 0) then - call sptrung(iromb, maxwv, idrti, imaxi, jmaxi, km, no, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, rlat, rlon, gi, go) - end if - do k = 1, km - ibo(k) = 0 - do n = 1, no - lo(n, k) = .true. - end do - end do + if(ispec.eq.0) then + call sptrung(iromb,maxwv,idrti,imaxi,jmaxi,km,no, & + iprime,iskipi,jskipi,mi,mo,0,0,0,rlat,rlon,gi,go) + endif + do k=1,km + ibo(k)=0 + do n=1,no + lo(n,k)=.true. + enddo + enddo else - do k = 1, km - ibo(k) = 1 - do n = 1, no - lo(n, k) = .false. - go(n, k) = 0. - end do - end do - end if - end subroutine polates4_grib2 + do k=1,km + ibo(k)=1 + do n=1,no + lo(n,k)=.false. + go(n,k)=0. + enddo + enddo + endif + endsubroutine polates4_grib2 !> Interpolate scalar fields (spectral). !> @@ -554,223 +554,223 @@ end subroutine polates4_grib2 !> - 42 invalid spectral method parameters !> !> @author Iredell @date 96-04-10 - subroutine polates4_grib1(ipopt, kgdsi, kgdso, mi, mo, km, ibi, gi, & - no, rlat, rlon, ibo, lo, go, iret) - integer, intent(in) :: ipopt(20), kgdsi(200) - integer, intent(in) :: kgdso(200), mi, mo - integer, intent(in) :: ibi(km), km - integer, intent(out) :: ibo(km), iret + subroutine polates4_grib1(ipopt,kgdsi,kgdso,mi,mo,km,ibi,gi, & + no,rlat,rlon,ibo,lo,go,iret) + integer,intent(in) :: ipopt(20),kgdsi(200) + integer,intent(in) :: kgdso(200),mi,mo + integer,intent(in) :: ibi(km),km + integer,intent(out) :: ibo(km),iret ! - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: gi(mi, km) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: go(mo, km) + real,intent(in) :: gi(mi,km) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: go(mo,km) ! - real, parameter :: fill = -9999. - real, parameter :: rerth = 6.3712e6 - real, parameter :: pi = 3.14159265358979 - real, parameter :: dpr = 180./pi + real,parameter :: fill=-9999. + real,parameter :: rerth=6.3712e6 + real,parameter :: pi=3.14159265358979 + real,parameter :: dpr=180./pi ! - integer :: idrti, idrto, ig, jg, im, jm - integer :: igo, jgo, imo, jmo - integer :: iscan, jscan, nscan - integer :: iscano, jscano, nscano - integer :: iskipi, jskipi - integer :: imaxi, jmaxi, ispec - integer :: ip, iprime, iproj, iromb, k - integer :: maxwv, n, ni, nj, nps, no + integer :: idrti,idrto,ig,jg,im,jm + integer :: igo,jgo,imo,jmo + integer :: iscan,jscan,nscan + integer :: iscano,jscano,nscano + integer :: iskipi,jskipi + integer :: imaxi,jmaxi,ispec + integer :: ip,iprime,iproj,iromb,k + integer :: maxwv,n,ni,nj,nps,no ! - real :: de, dr, dy - real :: dlat, dlon, dlato, dlono - real :: go2(mo, km), h, hi, hj + real :: de,dr,dy + real :: dlat,dlon,dlato,dlono + real :: go2(mo,km),h,hi,hj real :: orient - real :: rlat1, rlon1, rlat2, rlon2, rlati - real :: xmesh, xp, yp - real :: xpts(mo), ypts(mo) + real :: rlat1,rlon1,rlat2,rlon2,rlati + real :: xmesh,xp,yp + real :: xpts(mo),ypts(mo) - type(grib1_descriptor) :: desc_in, desc_out - class(ip_grid), allocatable :: grid_in, grid_out + type(grib1_descriptor) :: desc_in,desc_out + class(ip_grid),allocatable :: grid_in,grid_out - desc_in = init_descriptor(kgdsi) - desc_out = init_descriptor(kgdso) + desc_in=init_descriptor(kgdsi) + desc_out=init_descriptor(kgdso) - call init_grid(grid_in, desc_in) - call init_grid(grid_out, desc_out) + call init_grid(grid_in,desc_in) + call init_grid(grid_out,desc_out) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES. - iret = 0 - if (kgdso(1) .ge. 0) then - call gdswzd(grid_out, 0, mo, fill, xpts, ypts, rlon, rlat, no) - if (no .eq. 0) iret = 3 - end if + iret=0 + if(kgdso(1).ge.0) then + call gdswzd(grid_out,0,mo,fill,xpts,ypts,rlon,rlat,no) + if(no.eq.0) iret=3 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! AFFIRM APPROPRIATE INPUT GRID ! LAT/LON OR GAUSSIAN ! NO BITMAPS ! FULL ZONAL COVERAGE ! FULL MERIDIONAL COVERAGE - idrti = kgdsi(1) - im = kgdsi(2) - jm = kgdsi(3) - rlon1 = kgdsi(5)*1.e-3 - rlon2 = kgdsi(8)*1.e-3 - iscan = mod(kgdsi(11)/128, 2) - jscan = mod(kgdsi(11)/64, 2) - nscan = mod(kgdsi(11)/32, 2) - if (idrti .ne. 0 .and. idrti .ne. 4) iret = 41 - do k = 1, km - if (ibi(k) .ne. 0) iret = 41 - end do - if (iret .eq. 0) then - if (iscan .eq. 0) then - dlon = (mod(rlon2-rlon1-1+3600, 360.)+1)/(im-1) + idrti=kgdsi(1) + im=kgdsi(2) + jm=kgdsi(3) + rlon1=kgdsi(5)*1.e-3 + rlon2=kgdsi(8)*1.e-3 + iscan=mod(kgdsi(11)/128,2) + jscan=mod(kgdsi(11)/64,2) + nscan=mod(kgdsi(11)/32,2) + if(idrti.ne.0.and.idrti.ne.4) iret=41 + do k=1,km + if(ibi(k).ne.0) iret=41 + enddo + if(iret.eq.0) then + if(iscan.eq.0) then + dlon=(mod(rlon2-rlon1-1+3600,360.)+1)/(im-1) else - dlon = -(mod(rlon1-rlon2-1+3600, 360.)+1)/(im-1) - end if - ig = nint(360/abs(dlon)) - iprime = 1+mod(-nint(rlon1/dlon)+ig, ig) - imaxi = ig - jmaxi = jm - if (mod(ig, 2) .ne. 0 .or. im .lt. ig) iret = 41 - end if - if (iret .eq. 0 .and. idrti .eq. 0) then - rlat1 = kgdsi(4)*1.e-3 - rlat2 = kgdsi(7)*1.e-3 - dlat = (rlat2-rlat1)/(jm-1) - jg = nint(180/abs(dlat)) - if (jm .eq. jg) idrti = 256 - if (jm .ne. jg .and. jm .ne. jg+1) iret = 41 - elseif (iret .eq. 0 .and. idrti .eq. 4) then - jg = kgdsi(10)*2 - if (jm .ne. jg) iret = 41 - end if + dlon=-(mod(rlon1-rlon2-1+3600,360.)+1)/(im-1) + endif + ig=nint(360/abs(dlon)) + iprime=1+mod(-nint(rlon1/dlon)+ig,ig) + imaxi=ig + jmaxi=jm + if(mod(ig,2).ne.0.or.im.lt.ig) iret=41 + endif + if(iret.eq.0.and.idrti.eq.0) then + rlat1=kgdsi(4)*1.e-3 + rlat2=kgdsi(7)*1.e-3 + dlat=(rlat2-rlat1)/(jm-1) + jg=nint(180/abs(dlat)) + if(jm.eq.jg) idrti=256 + if(jm.ne.jg.and.jm.ne.jg+1) iret=41 + elseif(iret.eq.0.and.idrti.eq.4) then + jg=kgdsi(10)*2 + if(jm.ne.jg) iret=41 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SET PARAMETERS - if (iret .eq. 0) then - iromb = ipopt(1) - maxwv = ipopt(2) - if (maxwv .eq. -1) then - if (iromb .eq. 0 .and. idrti .eq. 4) maxwv = (jmaxi-1) - if (iromb .eq. 1 .and. idrti .eq. 4) maxwv = (jmaxi-1)/2 - if (iromb .eq. 0 .and. idrti .eq. 0) maxwv = (jmaxi-3)/2 - if (iromb .eq. 1 .and. idrti .eq. 0) maxwv = (jmaxi-3)/4 - if (iromb .eq. 0 .and. idrti .eq. 256) maxwv = (jmaxi-1)/2 - if (iromb .eq. 1 .and. idrti .eq. 256) maxwv = (jmaxi-1)/4 - end if - if ((iromb .ne. 0 .and. iromb .ne. 1) .or. maxwv .lt. 0) iret = 42 - end if + if(iret.eq.0) then + iromb=ipopt(1) + maxwv=ipopt(2) + if(maxwv.eq.-1) then + if(iromb.eq.0.and.idrti.eq.4) maxwv=(jmaxi-1) + if(iromb.eq.1.and.idrti.eq.4) maxwv=(jmaxi-1)/2 + if(iromb.eq.0.and.idrti.eq.0) maxwv=(jmaxi-3)/2 + if(iromb.eq.1.and.idrti.eq.0) maxwv=(jmaxi-3)/4 + if(iromb.eq.0.and.idrti.eq.256) maxwv=(jmaxi-1)/2 + if(iromb.eq.1.and.idrti.eq.256) maxwv=(jmaxi-1)/4 + endif + if((iromb.ne.0.and.iromb.ne.1).or.maxwv.lt.0) iret=42 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE - if (iret .eq. 0) then - if (nscan .eq. 0) then - iskipi = 1 - jskipi = im + if(iret.eq.0) then + if(nscan.eq.0) then + iskipi=1 + jskipi=im else - iskipi = jm - jskipi = 1 - end if - if (iscan .eq. 1) iskipi = -iskipi - if (jscan .eq. 0) jskipi = -jskipi - ispec = 0 + iskipi=jm + jskipi=1 + endif + if(iscan.eq.1) iskipi=-iskipi + if(jscan.eq.0) jskipi=-jskipi + ispec=0 ! SPECIAL CASE OF GLOBAL CYLINDRICAL GRID - if ((kgdso(1) .eq. 0 .or. kgdso(1) .eq. 4) .and. & - mod(kgdso(2), 2) .eq. 0 .and. kgdso(5) .eq. 0 .and. kgdso(11) .eq. 0) then - idrto = kgdso(1) - imo = kgdso(2) - jmo = kgdso(3) - rlon2 = kgdso(8)*1.e-3 - dlono = (mod(rlon2-1+3600, 360.)+1)/(imo-1) - igo = nint(360/abs(dlono)) - if (imo .eq. igo .and. idrto .eq. 0) then - rlat1 = kgdso(4)*1.e-3 - rlat2 = kgdso(7)*1.e-3 - dlat = (rlat2-rlat1)/(jmo-1) - jgo = nint(180/abs(dlat)) - if (jmo .eq. jgo) idrto = 256 - if (jmo .eq. jgo .or. jmo .eq. jgo+1) ispec = 1 - elseif (imo .eq. igo .and. idrto .eq. 4) then - jgo = kgdso(10)*2 - if (jmo .eq. jgo) ispec = 1 - end if - if (ispec .eq. 1) then - call sptrun(iromb, maxwv, idrti, imaxi, jmaxi, idrto, imo, jmo, & - km, iprime, iskipi, jskipi, mi, 0, 0, mo, 0, gi, go) - end if + if((kgdso(1).eq.0.or.kgdso(1).eq.4).and. & + mod(kgdso(2),2).eq.0.and.kgdso(5).eq.0.and.kgdso(11).eq.0) then + idrto=kgdso(1) + imo=kgdso(2) + jmo=kgdso(3) + rlon2=kgdso(8)*1.e-3 + dlono=(mod(rlon2-1+3600,360.)+1)/(imo-1) + igo=nint(360/abs(dlono)) + if(imo.eq.igo.and.idrto.eq.0) then + rlat1=kgdso(4)*1.e-3 + rlat2=kgdso(7)*1.e-3 + dlat=(rlat2-rlat1)/(jmo-1) + jgo=nint(180/abs(dlat)) + if(jmo.eq.jgo) idrto=256 + if(jmo.eq.jgo.or.jmo.eq.jgo+1) ispec=1 + elseif(imo.eq.igo.and.idrto.eq.4) then + jgo=kgdso(10)*2 + if(jmo.eq.jgo) ispec=1 + endif + if(ispec.eq.1) then + call sptrun(iromb,maxwv,idrti,imaxi,jmaxi,idrto,imo,jmo, & + km,iprime,iskipi,jskipi,mi,0,0,mo,0,gi,go) + endif ! SPECIAL CASE OF POLAR STEREOGRAPHIC GRID - elseif (kgdso(1) .eq. 5 .and. & - kgdso(2) .eq. kgdso(3) .and. mod(kgdso(2), 2) .eq. 1 .and. & - kgdso(8) .eq. kgdso(9) .and. kgdso(11) .eq. 64) then - nps = kgdso(2) - rlat1 = kgdso(4)*1.e-3 - rlon1 = kgdso(5)*1.e-3 - orient = kgdso(7)*1.e-3 - xmesh = kgdso(8) - iproj = mod(kgdso(10)/128, 2) - ip = (nps+1)/2 - h = (-1.)**iproj - de = (1.+sin(60./dpr))*rerth - dr = de*cos(rlat1/dpr)/(1+h*sin(rlat1/dpr)) - xp = 1-h*sin((rlon1-orient)/dpr)*dr/xmesh - yp = 1+cos((rlon1-orient)/dpr)*dr/xmesh - if (nint(xp) .eq. ip .and. nint(yp) .eq. ip) then - if (iproj .eq. 0) then - call sptruns(iromb, maxwv, idrti, imaxi, jmaxi, km, nps, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, & - 60., xmesh, orient, gi, go, go2) + elseif(kgdso(1).eq.5.and. & + kgdso(2).eq.kgdso(3).and.mod(kgdso(2),2).eq.1.and. & + kgdso(8).eq.kgdso(9).and.kgdso(11).eq.64) then + nps=kgdso(2) + rlat1=kgdso(4)*1.e-3 + rlon1=kgdso(5)*1.e-3 + orient=kgdso(7)*1.e-3 + xmesh=kgdso(8) + iproj=mod(kgdso(10)/128,2) + ip=(nps+1)/2 + h=(-1.)**iproj + de=(1.+sin(60./dpr))*rerth + dr=de*cos(rlat1/dpr)/(1+h*sin(rlat1/dpr)) + xp=1-h*sin((rlon1-orient)/dpr)*dr/xmesh + yp=1+cos((rlon1-orient)/dpr)*dr/xmesh + if(nint(xp).eq.ip.and.nint(yp).eq.ip) then + if(iproj.eq.0) then + call sptruns(iromb,maxwv,idrti,imaxi,jmaxi,km,nps, & + iprime,iskipi,jskipi,mi,mo,0,0,0, & + 60.,xmesh,orient,gi,go,go2) else - call sptruns(iromb, maxwv, idrti, imaxi, jmaxi, km, nps, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, & - 60., xmesh, orient, gi, go2, go) - end if - ispec = 1 - end if + call sptruns(iromb,maxwv,idrti,imaxi,jmaxi,km,nps, & + iprime,iskipi,jskipi,mi,mo,0,0,0, & + 60.,xmesh,orient,gi,go2,go) + endif + ispec=1 + endif ! SPECIAL CASE OF MERCATOR GRID - elseif (kgdso(1) .eq. 1) then - ni = kgdso(2) - nj = kgdso(3) - rlat1 = kgdso(4)*1.e-3 - rlon1 = kgdso(5)*1.e-3 - rlon2 = kgdso(8)*1.e-3 - rlati = kgdso(9)*1.e-3 - iscano = mod(kgdso(11)/128, 2) - jscano = mod(kgdso(11)/64, 2) - nscano = mod(kgdso(11)/32, 2) - dy = kgdso(13) - hi = (-1.)**iscano - hj = (-1.)**(1-jscano) - dlono = hi*(mod(hi*(rlon2-rlon1)-1+3600, 360.)+1)/(ni-1) - dlato = hj*dy/(rerth*cos(rlati/dpr))*dpr - if (nscano .eq. 0) then - call sptrunm(iromb, maxwv, idrti, imaxi, jmaxi, km, ni, nj, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, & - rlat1, rlon1, dlato, dlono, gi, go) - ispec = 1 - end if - end if + elseif(kgdso(1).eq.1) then + ni=kgdso(2) + nj=kgdso(3) + rlat1=kgdso(4)*1.e-3 + rlon1=kgdso(5)*1.e-3 + rlon2=kgdso(8)*1.e-3 + rlati=kgdso(9)*1.e-3 + iscano=mod(kgdso(11)/128,2) + jscano=mod(kgdso(11)/64,2) + nscano=mod(kgdso(11)/32,2) + dy=kgdso(13) + hi=(-1.)**iscano + hj=(-1.)**(1-jscano) + dlono=hi*(mod(hi*(rlon2-rlon1)-1+3600,360.)+1)/(ni-1) + dlato=hj*dy/(rerth*cos(rlati/dpr))*dpr + if(nscano.eq.0) then + call sptrunm(iromb,maxwv,idrti,imaxi,jmaxi,km,ni,nj, & + iprime,iskipi,jskipi,mi,mo,0,0,0, & + rlat1,rlon1,dlato,dlono,gi,go) + ispec=1 + endif + endif ! GENERAL SLOW CASE - if (ispec .eq. 0) then - call sptrung(iromb, maxwv, idrti, imaxi, jmaxi, km, no, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, rlat, rlon, gi, go) - end if - do k = 1, km - ibo(k) = 0 - do n = 1, no - lo(n, k) = .true. - end do - end do + if(ispec.eq.0) then + call sptrung(iromb,maxwv,idrti,imaxi,jmaxi,km,no, & + iprime,iskipi,jskipi,mi,mo,0,0,0,rlat,rlon,gi,go) + endif + do k=1,km + ibo(k)=0 + do n=1,no + lo(n,k)=.true. + enddo + enddo else - do k = 1, km - ibo(k) = 1 - do n = 1, no - lo(n, k) = .false. - go(n, k) = 0. - end do - end do - end if + do k=1,km + ibo(k)=1 + do n=1,no + lo(n,k)=.false. + go(n,k)=0. + enddo + enddo + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine polates4_grib1 + endsubroutine polates4_grib1 !> Interpolate vector fields (spectral). !> @@ -881,255 +881,255 @@ end subroutine polates4_grib1 !> - 42 invalid spectral method parameters !> !> @author IREDELL @date 96-04-10 - subroutine polatev4_grib2(ipopt, igdtnumi, igdtmpli, igdtleni, & - igdtnumo, igdtmplo, igdtleno, & - mi, mo, km, ibi, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - integer, intent(in) :: ipopt(20), ibi(km) - integer, intent(in) :: km, mi, mo - integer, intent(out) :: iret, ibo(km), no - integer, intent(in) :: igdtnumi, igdtleni - integer, intent(in) :: igdtmpli(igdtleni) - integer, intent(in) :: igdtnumo, igdtleno - integer, intent(in) :: igdtmplo(igdtleno) + subroutine polatev4_grib2(ipopt,igdtnumi,igdtmpli,igdtleni, & + igdtnumo,igdtmplo,igdtleno, & + mi,mo,km,ibi,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + integer,intent(in) :: ipopt(20),ibi(km) + integer,intent(in) :: km,mi,mo + integer,intent(out) :: iret,ibo(km),no + integer,intent(in) :: igdtnumi,igdtleni + integer,intent(in) :: igdtmpli(igdtleni) + integer,intent(in) :: igdtnumo,igdtleno + integer,intent(in) :: igdtmplo(igdtleno) ! - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: ui(mi, km), vi(mi, km) - real, intent(out) :: uo(mo, km), vo(mo, km) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: crot(mo), srot(mo) + real,intent(in) :: ui(mi,km),vi(mi,km) + real,intent(out) :: uo(mo,km),vo(mo,km) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: crot(mo),srot(mo) ! - real, parameter :: fill = -9999. - real, parameter :: pi = 3.14159265358979 - real, parameter :: dpr = 180./pi + real,parameter :: fill=-9999. + real,parameter :: pi=3.14159265358979 + real,parameter :: dpr=180./pi ! - integer :: idrto, iromb, iskipi, ispec - integer :: idrti, imaxi, jmaxi, im, jm - integer :: iprime, ig, imo, jmo, igo, jgo - integer :: iscan, jscan, nscan - integer :: iscano, jscano, nscano - integer :: iscale, ip, iproj, jskipi, jg - integer :: k, maxwv, n, ni, nj, nps + integer :: idrto,iromb,iskipi,ispec + integer :: idrti,imaxi,jmaxi,im,jm + integer :: iprime,ig,imo,jmo,igo,jgo + integer :: iscan,jscan,nscan + integer :: iscano,jscano,nscano + integer :: iscale,ip,iproj,jskipi,jg + integer :: k,maxwv,n,ni,nj,nps ! - real :: dlat, dlon, dlato, dlono, de, dr, dy - real :: dum, e2, h, hi, hj, dumm(1) - real :: orient, rerth, slat - real :: rlat1, rlon1, rlat2, rlon2, rlati - real :: urot, vrot, uo2(mo, km), vo2(mo, km) - real :: xmesh, xp, yp, xpts(mo), ypts(mo) + real :: dlat,dlon,dlato,dlono,de,dr,dy + real :: dum,e2,h,hi,hj,dumm(1) + real :: orient,rerth,slat + real :: rlat1,rlon1,rlat2,rlon2,rlati + real :: urot,vrot,uo2(mo,km),vo2(mo,km) + real :: xmesh,xp,yp,xpts(mo),ypts(mo) - type(grib2_descriptor) :: desc_in, desc_out - class(ip_grid), allocatable :: grid_in, grid_out + type(grib2_descriptor) :: desc_in,desc_out + class(ip_grid),allocatable :: grid_in,grid_out - desc_in = init_descriptor(igdtnumi, igdtleni, igdtmpli) - desc_out = init_descriptor(igdtnumo, igdtleno, igdtmplo) + desc_in=init_descriptor(igdtnumi,igdtleni,igdtmpli) + desc_out=init_descriptor(igdtnumo,igdtleno,igdtmplo) - call init_grid(grid_in, desc_in) - call init_grid(grid_out, desc_out) + call init_grid(grid_in,desc_in) + call init_grid(grid_out,desc_out) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES. - iret = 0 - if (igdtnumo .ge. 0) then - call gdswzd(grid_out, 0, mo, fill, xpts, ypts, & - rlon, rlat, no, crot, srot) - if (no .eq. 0) iret = 3 - end if + iret=0 + if(igdtnumo.ge.0) then + call gdswzd(grid_out,0,mo,fill,xpts,ypts, & + rlon,rlat,no,crot,srot) + if(no.eq.0) iret=3 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! AFFIRM APPROPRIATE INPUT GRID ! LAT/LON OR GAUSSIAN ! NO BITMAPS ! FULL ZONAL COVERAGE ! FULL MERIDIONAL COVERAGE - idrti = igdtnumi - if (idrti .eq. 40) idrti = 4 - if (idrti .eq. 0 .or. idrti .eq. 4) then - im = igdtmpli(8) - jm = igdtmpli(9) - iscale = igdtmpli(10)*igdtmpli(11) - if (iscale .eq. 0) iscale = 10**6 - rlon1 = float(igdtmpli(13))/float(iscale) - rlon2 = float(igdtmpli(16))/float(iscale) - iscan = mod(igdtmpli(19)/128, 2) - jscan = mod(igdtmpli(19)/64, 2) - nscan = mod(igdtmpli(19)/32, 2) + idrti=igdtnumi + if(idrti.eq.40) idrti=4 + if(idrti.eq.0.or.idrti.eq.4) then + im=igdtmpli(8) + jm=igdtmpli(9) + iscale=igdtmpli(10)*igdtmpli(11) + if(iscale.eq.0) iscale=10**6 + rlon1=float(igdtmpli(13))/float(iscale) + rlon2=float(igdtmpli(16))/float(iscale) + iscan=mod(igdtmpli(19)/128,2) + jscan=mod(igdtmpli(19)/64,2) + nscan=mod(igdtmpli(19)/32,2) else - iret = 41 - end if - do k = 1, km - if (ibi(k) .ne. 0) iret = 41 - end do - if (iret .eq. 0) then - if (iscan .eq. 0) then - dlon = (mod(rlon2-rlon1-1+3600, 360.)+1)/(im-1) + iret=41 + endif + do k=1,km + if(ibi(k).ne.0) iret=41 + enddo + if(iret.eq.0) then + if(iscan.eq.0) then + dlon=(mod(rlon2-rlon1-1+3600,360.)+1)/(im-1) else - dlon = -(mod(rlon1-rlon2-1+3600, 360.)+1)/(im-1) - end if - ig = nint(360/abs(dlon)) - iprime = 1+mod(-nint(rlon1/dlon)+ig, ig) - imaxi = ig - jmaxi = jm - if (mod(ig, 2) .ne. 0 .or. im .lt. ig) iret = 41 - end if - if (iret .eq. 0 .and. idrti .eq. 0) then - iscale = igdtmpli(10)*igdtmpli(11) - if (iscale .eq. 0) iscale = 10**6 - rlat1 = float(igdtmpli(12))/float(iscale) - rlat2 = float(igdtmpli(15))/float(iscale) - dlat = (rlat2-rlat1)/(jm-1) - jg = nint(180/abs(dlat)) - if (jm .eq. jg) idrti = 256 - if (jm .ne. jg .and. jm .ne. jg+1) iret = 41 - elseif (iret .eq. 0 .and. idrti .eq. 4) then - jg = igdtmpli(18)*2 - if (jm .ne. jg) iret = 41 - end if + dlon=-(mod(rlon1-rlon2-1+3600,360.)+1)/(im-1) + endif + ig=nint(360/abs(dlon)) + iprime=1+mod(-nint(rlon1/dlon)+ig,ig) + imaxi=ig + jmaxi=jm + if(mod(ig,2).ne.0.or.im.lt.ig) iret=41 + endif + if(iret.eq.0.and.idrti.eq.0) then + iscale=igdtmpli(10)*igdtmpli(11) + if(iscale.eq.0) iscale=10**6 + rlat1=float(igdtmpli(12))/float(iscale) + rlat2=float(igdtmpli(15))/float(iscale) + dlat=(rlat2-rlat1)/(jm-1) + jg=nint(180/abs(dlat)) + if(jm.eq.jg) idrti=256 + if(jm.ne.jg.and.jm.ne.jg+1) iret=41 + elseif(iret.eq.0.and.idrti.eq.4) then + jg=igdtmpli(18)*2 + if(jm.ne.jg) iret=41 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SET PARAMETERS - if (iret .eq. 0) then - iromb = ipopt(1) - maxwv = ipopt(2) - if (maxwv .eq. -1) then - if (iromb .eq. 0 .and. idrti .eq. 4) maxwv = (jmaxi-1) - if (iromb .eq. 1 .and. idrti .eq. 4) maxwv = (jmaxi-1)/2 - if (iromb .eq. 0 .and. idrti .eq. 0) maxwv = (jmaxi-3)/2 - if (iromb .eq. 1 .and. idrti .eq. 0) maxwv = (jmaxi-3)/4 - if (iromb .eq. 0 .and. idrti .eq. 256) maxwv = (jmaxi-1)/2 - if (iromb .eq. 1 .and. idrti .eq. 256) maxwv = (jmaxi-1)/4 - end if - if ((iromb .ne. 0 .and. iromb .ne. 1) .or. maxwv .lt. 0) iret = 42 - end if + if(iret.eq.0) then + iromb=ipopt(1) + maxwv=ipopt(2) + if(maxwv.eq.-1) then + if(iromb.eq.0.and.idrti.eq.4) maxwv=(jmaxi-1) + if(iromb.eq.1.and.idrti.eq.4) maxwv=(jmaxi-1)/2 + if(iromb.eq.0.and.idrti.eq.0) maxwv=(jmaxi-3)/2 + if(iromb.eq.1.and.idrti.eq.0) maxwv=(jmaxi-3)/4 + if(iromb.eq.0.and.idrti.eq.256) maxwv=(jmaxi-1)/2 + if(iromb.eq.1.and.idrti.eq.256) maxwv=(jmaxi-1)/4 + endif + if((iromb.ne.0.and.iromb.ne.1).or.maxwv.lt.0) iret=42 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE - if (iret .eq. 0) then - if (nscan .eq. 0) then - iskipi = 1 - jskipi = im + if(iret.eq.0) then + if(nscan.eq.0) then + iskipi=1 + jskipi=im else - iskipi = jm - jskipi = 1 - end if - if (iscan .eq. 1) iskipi = -iskipi - if (jscan .eq. 0) jskipi = -jskipi - ispec = 0 + iskipi=jm + jskipi=1 + endif + if(iscan.eq.1) iskipi=-iskipi + if(jscan.eq.0) jskipi=-jskipi + ispec=0 ! SPECIAL CASE OF GLOBAL CYLINDRICAL GRID - if ((igdtnumo .eq. 0 .or. igdtnumo .eq. 40) .and. & - mod(igdtmplo(8), 2) .eq. 0 .and. igdtmplo(13) .eq. 0 .and. & - igdtmplo(19) .eq. 0) then - idrto = igdtnumo - if (idrto .eq. 40) idrto = 4 - imo = igdtmplo(8) - jmo = igdtmplo(9) - iscale = igdtmplo(10)*igdtmplo(11) - if (iscale .eq. 0) iscale = 10**6 - rlon2 = float(igdtmplo(16))/float(iscale) - dlono = (mod(rlon2-1+3600, 360.)+1)/(imo-1) - igo = nint(360/abs(dlono)) - if (imo .eq. igo .and. idrto .eq. 0) then - rlat1 = float(igdtmplo(12))/float(iscale) - rlat2 = float(igdtmplo(15))/float(iscale) - dlat = (rlat2-rlat1)/(jmo-1) - jgo = nint(180/abs(dlat)) - if (jmo .eq. jgo) idrto = 256 - if (jmo .eq. jgo .or. jmo .eq. jgo+1) ispec = 1 - elseif (imo .eq. igo .and. idrto .eq. 4) then - jgo = igdtmplo(18)*2 - if (jmo .eq. jgo) ispec = 1 - end if - if (ispec .eq. 1) then - call sptrunv(iromb, maxwv, idrti, imaxi, jmaxi, idrto, imo, jmo, & - km, iprime, iskipi, jskipi, mi, 0, 0, mo, 0, ui, vi, & - .true., uo, vo, .false., dumm, dumm, .false., dumm, dumm) - end if + if((igdtnumo.eq.0.or.igdtnumo.eq.40).and. & + mod(igdtmplo(8),2).eq.0.and.igdtmplo(13).eq.0.and. & + igdtmplo(19).eq.0) then + idrto=igdtnumo + if(idrto.eq.40) idrto=4 + imo=igdtmplo(8) + jmo=igdtmplo(9) + iscale=igdtmplo(10)*igdtmplo(11) + if(iscale.eq.0) iscale=10**6 + rlon2=float(igdtmplo(16))/float(iscale) + dlono=(mod(rlon2-1+3600,360.)+1)/(imo-1) + igo=nint(360/abs(dlono)) + if(imo.eq.igo.and.idrto.eq.0) then + rlat1=float(igdtmplo(12))/float(iscale) + rlat2=float(igdtmplo(15))/float(iscale) + dlat=(rlat2-rlat1)/(jmo-1) + jgo=nint(180/abs(dlat)) + if(jmo.eq.jgo) idrto=256 + if(jmo.eq.jgo.or.jmo.eq.jgo+1) ispec=1 + elseif(imo.eq.igo.and.idrto.eq.4) then + jgo=igdtmplo(18)*2 + if(jmo.eq.jgo) ispec=1 + endif + if(ispec.eq.1) then + call sptrunv(iromb,maxwv,idrti,imaxi,jmaxi,idrto,imo,jmo, & + km,iprime,iskipi,jskipi,mi,0,0,mo,0,ui,vi, & + .true.,uo,vo,.false.,dumm,dumm,.false.,dumm,dumm) + endif ! SPECIAL CASE OF POLAR STEREOGRAPHIC GRID - elseif (igdtnumo .eq. 20 .and. & - igdtmplo(8) .eq. igdtmplo(9) .and. mod(igdtmplo(8), 2) .eq. 1 .and. & - igdtmplo(15) .eq. igdtmplo(16) .and. igdtmplo(18) .eq. 64 .and. & - mod(igdtmplo(12)/8, 2) .eq. 1) then - nps = igdtmplo(8) - rlat1 = float(igdtmplo(10))*1.e-6 - rlon1 = float(igdtmplo(11))*1.e-6 - orient = float(igdtmplo(14))*1.e-6 - xmesh = float(igdtmplo(15))*1.e-3 - iproj = mod(igdtmplo(17)/128, 2) - ip = (nps+1)/2 - h = (-1.)**iproj - slat = float(abs(igdtmplo(13)))*1.e-6 - call earth_radius(igdtmplo, igdtleno, rerth, e2) - de = (1.+sin(slat/dpr))*rerth - dr = de*cos(rlat1/dpr)/(1+h*sin(rlat1/dpr)) - xp = 1-h*sin((rlon1-orient)/dpr)*dr/xmesh - yp = 1+cos((rlon1-orient)/dpr)*dr/xmesh - if (nint(xp) .eq. ip .and. nint(yp) .eq. ip) then - if (iproj .eq. 0) then - call sptrunsv(iromb, maxwv, idrti, imaxi, jmaxi, km, nps, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, & - slat, xmesh, orient, ui, vi, .true., uo, vo, uo2, vo2, & - .false., dumm, dumm, dumm, dumm, & - .false., dumm, dumm, dumm, dumm) + elseif(igdtnumo.eq.20.and. & + igdtmplo(8).eq.igdtmplo(9).and.mod(igdtmplo(8),2).eq.1.and. & + igdtmplo(15).eq.igdtmplo(16).and.igdtmplo(18).eq.64.and. & + mod(igdtmplo(12)/8,2).eq.1) then + nps=igdtmplo(8) + rlat1=float(igdtmplo(10))*1.e-6 + rlon1=float(igdtmplo(11))*1.e-6 + orient=float(igdtmplo(14))*1.e-6 + xmesh=float(igdtmplo(15))*1.e-3 + iproj=mod(igdtmplo(17)/128,2) + ip=(nps+1)/2 + h=(-1.)**iproj + slat=float(abs(igdtmplo(13)))*1.e-6 + call earth_radius(igdtmplo,igdtleno,rerth,e2) + de=(1.+sin(slat/dpr))*rerth + dr=de*cos(rlat1/dpr)/(1+h*sin(rlat1/dpr)) + xp=1-h*sin((rlon1-orient)/dpr)*dr/xmesh + yp=1+cos((rlon1-orient)/dpr)*dr/xmesh + if(nint(xp).eq.ip.and.nint(yp).eq.ip) then + if(iproj.eq.0) then + call sptrunsv(iromb,maxwv,idrti,imaxi,jmaxi,km,nps, & + iprime,iskipi,jskipi,mi,mo,0,0,0, & + slat,xmesh,orient,ui,vi,.true.,uo,vo,uo2,vo2, & + .false.,dumm,dumm,dumm,dumm, & + .false.,dumm,dumm,dumm,dumm) else - call sptrunsv(iromb, maxwv, idrti, imaxi, jmaxi, km, nps, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, & - slat, xmesh, orient, ui, vi, .true., uo2, vo2, uo, vo, & - .false., dumm, dumm, dumm, dumm, & - .false., dumm, dumm, dumm, dumm) - end if - ispec = 1 - end if + call sptrunsv(iromb,maxwv,idrti,imaxi,jmaxi,km,nps, & + iprime,iskipi,jskipi,mi,mo,0,0,0, & + slat,xmesh,orient,ui,vi,.true.,uo2,vo2,uo,vo, & + .false.,dumm,dumm,dumm,dumm, & + .false.,dumm,dumm,dumm,dumm) + endif + ispec=1 + endif ! SPECIAL CASE OF MERCATOR GRID - elseif (igdtnumo .eq. 10) then - ni = igdtmplo(8) - nj = igdtmplo(9) - rlat1 = float(igdtmplo(10))*1.0e-6 - rlon1 = float(igdtmplo(11))*1.0e-6 - rlon2 = float(igdtmplo(15))*1.0e-6 - rlati = float(igdtmplo(13))*1.0e-6 - iscano = mod(igdtmplo(16)/128, 2) - jscano = mod(igdtmplo(16)/64, 2) - nscano = mod(igdtmplo(16)/32, 2) - dy = float(igdtmplo(19))*1.0e-3 - hi = (-1.)**iscano - hj = (-1.)**(1-jscano) - call earth_radius(igdtmplo, igdtleno, rerth, e2) - dlono = hi*(mod(hi*(rlon2-rlon1)-1+3600, 360.)+1)/(ni-1) - dlato = hj*dy/(rerth*cos(rlati/dpr))*dpr - if (nscano .eq. 0) then - call sptrunmv(iromb, maxwv, idrti, imaxi, jmaxi, km, ni, nj, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, & - rlat1, rlon1, dlato, dlono, ui, vi, & - .true., uo, vo, .false., dumm, dumm, .false., dumm, dumm) - ispec = 1 - end if - end if + elseif(igdtnumo.eq.10) then + ni=igdtmplo(8) + nj=igdtmplo(9) + rlat1=float(igdtmplo(10))*1.0e-6 + rlon1=float(igdtmplo(11))*1.0e-6 + rlon2=float(igdtmplo(15))*1.0e-6 + rlati=float(igdtmplo(13))*1.0e-6 + iscano=mod(igdtmplo(16)/128,2) + jscano=mod(igdtmplo(16)/64,2) + nscano=mod(igdtmplo(16)/32,2) + dy=float(igdtmplo(19))*1.0e-3 + hi=(-1.)**iscano + hj=(-1.)**(1-jscano) + call earth_radius(igdtmplo,igdtleno,rerth,e2) + dlono=hi*(mod(hi*(rlon2-rlon1)-1+3600,360.)+1)/(ni-1) + dlato=hj*dy/(rerth*cos(rlati/dpr))*dpr + if(nscano.eq.0) then + call sptrunmv(iromb,maxwv,idrti,imaxi,jmaxi,km,ni,nj, & + iprime,iskipi,jskipi,mi,mo,0,0,0, & + rlat1,rlon1,dlato,dlono,ui,vi, & + .true.,uo,vo,.false.,dumm,dumm,.false.,dumm,dumm) + ispec=1 + endif + endif ! GENERAL SLOW CASE - if (ispec .eq. 0) then - call sptrungv(iromb, maxwv, idrti, imaxi, jmaxi, km, no, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, rlat, rlon, & - ui, vi, .true., uo, vo, .false., dumm, dumm, .false., dumm, dumm) - do k = 1, km - ibo(k) = 0 - do n = 1, no - lo(n, k) = .true. - urot = crot(n)*uo(n, k)-srot(n)*vo(n, k) - vrot = srot(n)*uo(n, k)+crot(n)*vo(n, k) - uo(n, k) = urot - vo(n, k) = vrot - end do - end do - end if + if(ispec.eq.0) then + call sptrungv(iromb,maxwv,idrti,imaxi,jmaxi,km,no, & + iprime,iskipi,jskipi,mi,mo,0,0,0,rlat,rlon, & + ui,vi,.true.,uo,vo,.false.,dumm,dumm,.false.,dumm,dumm) + do k=1,km + ibo(k)=0 + do n=1,no + lo(n,k)=.true. + urot=crot(n)*uo(n,k)-srot(n)*vo(n,k) + vrot=srot(n)*uo(n,k)+crot(n)*vo(n,k) + uo(n,k)=urot + vo(n,k)=vrot + enddo + enddo + endif else - do k = 1, km - ibo(k) = 1 - do n = 1, no - lo(n, k) = .false. - uo(n, k) = 0. - vo(n, k) = 0. - end do - end do - end if + do k=1,km + ibo(k)=1 + do n=1,no + lo(n,k)=.false. + uo(n,k)=0. + vo(n,k)=0. + enddo + enddo + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine polatev4_grib2 + endsubroutine polatev4_grib2 !> Interpolate vector fields (spectral). !> @@ -1215,232 +1215,232 @@ end subroutine polatev4_grib2 !> - 42 invalid spectral method parameters !> !> @author IREDELL @date 96-04-10 - subroutine polatev4_grib1(ipopt, kgdsi, kgdso, mi, mo, km, ibi, ui, vi, & - no, rlat, rlon, crot, srot, ibo, lo, uo, vo, iret) - integer, intent(in) :: ipopt(20), ibi(km) - integer, intent(in) :: km, mi, mo - integer, intent(out) :: iret, ibo(km) - integer, intent(in) :: kgdsi(200), kgdso(200) + subroutine polatev4_grib1(ipopt,kgdsi,kgdso,mi,mo,km,ibi,ui,vi, & + no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) + integer,intent(in) :: ipopt(20),ibi(km) + integer,intent(in) :: km,mi,mo + integer,intent(out) :: iret,ibo(km) + integer,intent(in) :: kgdsi(200),kgdso(200) ! - logical*1, intent(out) :: lo(mo, km) + logical*1,intent(out) :: lo(mo,km) ! - real, intent(in) :: ui(mi, km), vi(mi, km) - real, intent(out) :: uo(mo, km), vo(mo, km) - real, intent(inout) :: rlat(mo), rlon(mo) - real, intent(out) :: crot(mo), srot(mo) + real,intent(in) :: ui(mi,km),vi(mi,km) + real,intent(out) :: uo(mo,km),vo(mo,km) + real,intent(inout) :: rlat(mo),rlon(mo) + real,intent(out) :: crot(mo),srot(mo) ! - real, parameter :: fill = -9999. - real, parameter :: rerth = 6.3712e6 - real, parameter :: pi = 3.14159265358979 - real, parameter :: dpr = 180./pi + real,parameter :: fill=-9999. + real,parameter :: rerth=6.3712e6 + real,parameter :: pi=3.14159265358979 + real,parameter :: dpr=180./pi ! - integer :: idrto, iromb, iskipi, ispec - integer :: idrti, imaxi, jmaxi, im, jm - integer :: iprime, ig, imo, jmo, igo, jgo - integer :: iscan, jscan, nscan - integer :: iscano, jscano, nscano - integer :: ip, iproj, jskipi, jg - integer :: k, maxwv, n, ni, nj, no, nps + integer :: idrto,iromb,iskipi,ispec + integer :: idrti,imaxi,jmaxi,im,jm + integer :: iprime,ig,imo,jmo,igo,jgo + integer :: iscan,jscan,nscan + integer :: iscano,jscano,nscano + integer :: ip,iproj,jskipi,jg + integer :: k,maxwv,n,ni,nj,no,nps ! - real :: dlat, dlon, dlato, dlono, de, dr, dy - real :: dum, h, hi, hj, dumm(1) + real :: dlat,dlon,dlato,dlono,de,dr,dy + real :: dum,h,hi,hj,dumm(1) real :: orient - real :: rlat1, rlon1, rlat2, rlon2, rlati - real :: urot, vrot, uo2(mo, km), vo2(mo, km) - real :: xmesh, xp, yp, xpts(mo), ypts(mo) + real :: rlat1,rlon1,rlat2,rlon2,rlati + real :: urot,vrot,uo2(mo,km),vo2(mo,km) + real :: xmesh,xp,yp,xpts(mo),ypts(mo) - type(grib1_descriptor) :: desc_in, desc_out - class(ip_grid), allocatable :: grid_in, grid_out + type(grib1_descriptor) :: desc_in,desc_out + class(ip_grid),allocatable :: grid_in,grid_out - desc_in = init_descriptor(kgdsi) - desc_out = init_descriptor(kgdso) + desc_in=init_descriptor(kgdsi) + desc_out=init_descriptor(kgdso) - call init_grid(grid_in, desc_in) - call init_grid(grid_out, desc_out) + call init_grid(grid_in,desc_in) + call init_grid(grid_out,desc_out) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES. - iret = 0 - if (kgdso(1) .ge. 0) then - call gdswzd(grid_out, 0, mo, fill, xpts, ypts, rlon, rlat, no, crot, srot) - if (no .eq. 0) iret = 3 - end if + iret=0 + if(kgdso(1).ge.0) then + call gdswzd(grid_out,0,mo,fill,xpts,ypts,rlon,rlat,no,crot,srot) + if(no.eq.0) iret=3 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! AFFIRM APPROPRIATE INPUT GRID ! LAT/LON OR GAUSSIAN ! NO BITMAPS ! FULL ZONAL COVERAGE ! FULL MERIDIONAL COVERAGE - idrti = kgdsi(1) - im = kgdsi(2) - jm = kgdsi(3) - rlon1 = kgdsi(5)*1.e-3 - rlon2 = kgdsi(8)*1.e-3 - iscan = mod(kgdsi(11)/128, 2) - jscan = mod(kgdsi(11)/64, 2) - nscan = mod(kgdsi(11)/32, 2) - if (idrti .ne. 0 .and. idrti .ne. 4) iret = 41 - do k = 1, km - if (ibi(k) .ne. 0) iret = 41 - end do - if (iret .eq. 0) then - if (iscan .eq. 0) then - dlon = (mod(rlon2-rlon1-1+3600, 360.)+1)/(im-1) + idrti=kgdsi(1) + im=kgdsi(2) + jm=kgdsi(3) + rlon1=kgdsi(5)*1.e-3 + rlon2=kgdsi(8)*1.e-3 + iscan=mod(kgdsi(11)/128,2) + jscan=mod(kgdsi(11)/64,2) + nscan=mod(kgdsi(11)/32,2) + if(idrti.ne.0.and.idrti.ne.4) iret=41 + do k=1,km + if(ibi(k).ne.0) iret=41 + enddo + if(iret.eq.0) then + if(iscan.eq.0) then + dlon=(mod(rlon2-rlon1-1+3600,360.)+1)/(im-1) else - dlon = -(mod(rlon1-rlon2-1+3600, 360.)+1)/(im-1) - end if - ig = nint(360/abs(dlon)) - iprime = 1+mod(-nint(rlon1/dlon)+ig, ig) - imaxi = ig - jmaxi = jm - if (mod(ig, 2) .ne. 0 .or. im .lt. ig) iret = 41 - end if - if (iret .eq. 0 .and. idrti .eq. 0) then - rlat1 = kgdsi(4)*1.e-3 - rlat2 = kgdsi(7)*1.e-3 - dlat = (rlat2-rlat1)/(jm-1) - jg = nint(180/abs(dlat)) - if (jm .eq. jg) idrti = 256 - if (jm .ne. jg .and. jm .ne. jg+1) iret = 41 - elseif (iret .eq. 0 .and. idrti .eq. 4) then - jg = kgdsi(10)*2 - if (jm .ne. jg) iret = 41 - end if + dlon=-(mod(rlon1-rlon2-1+3600,360.)+1)/(im-1) + endif + ig=nint(360/abs(dlon)) + iprime=1+mod(-nint(rlon1/dlon)+ig,ig) + imaxi=ig + jmaxi=jm + if(mod(ig,2).ne.0.or.im.lt.ig) iret=41 + endif + if(iret.eq.0.and.idrti.eq.0) then + rlat1=kgdsi(4)*1.e-3 + rlat2=kgdsi(7)*1.e-3 + dlat=(rlat2-rlat1)/(jm-1) + jg=nint(180/abs(dlat)) + if(jm.eq.jg) idrti=256 + if(jm.ne.jg.and.jm.ne.jg+1) iret=41 + elseif(iret.eq.0.and.idrti.eq.4) then + jg=kgdsi(10)*2 + if(jm.ne.jg) iret=41 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! SET PARAMETERS - if (iret .eq. 0) then - iromb = ipopt(1) - maxwv = ipopt(2) - if (maxwv .eq. -1) then - if (iromb .eq. 0 .and. idrti .eq. 4) maxwv = (jmaxi-1) - if (iromb .eq. 1 .and. idrti .eq. 4) maxwv = (jmaxi-1)/2 - if (iromb .eq. 0 .and. idrti .eq. 0) maxwv = (jmaxi-3)/2 - if (iromb .eq. 1 .and. idrti .eq. 0) maxwv = (jmaxi-3)/4 - if (iromb .eq. 0 .and. idrti .eq. 256) maxwv = (jmaxi-1)/2 - if (iromb .eq. 1 .and. idrti .eq. 256) maxwv = (jmaxi-1)/4 - end if - if ((iromb .ne. 0 .and. iromb .ne. 1) .or. maxwv .lt. 0) iret = 42 - end if + if(iret.eq.0) then + iromb=ipopt(1) + maxwv=ipopt(2) + if(maxwv.eq.-1) then + if(iromb.eq.0.and.idrti.eq.4) maxwv=(jmaxi-1) + if(iromb.eq.1.and.idrti.eq.4) maxwv=(jmaxi-1)/2 + if(iromb.eq.0.and.idrti.eq.0) maxwv=(jmaxi-3)/2 + if(iromb.eq.1.and.idrti.eq.0) maxwv=(jmaxi-3)/4 + if(iromb.eq.0.and.idrti.eq.256) maxwv=(jmaxi-1)/2 + if(iromb.eq.1.and.idrti.eq.256) maxwv=(jmaxi-1)/4 + endif + if((iromb.ne.0.and.iromb.ne.1).or.maxwv.lt.0) iret=42 + endif ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! INTERPOLATE - if (iret .eq. 0) then - if (nscan .eq. 0) then - iskipi = 1 - jskipi = im + if(iret.eq.0) then + if(nscan.eq.0) then + iskipi=1 + jskipi=im else - iskipi = jm - jskipi = 1 - end if - if (iscan .eq. 1) iskipi = -iskipi - if (jscan .eq. 0) jskipi = -jskipi - ispec = 0 + iskipi=jm + jskipi=1 + endif + if(iscan.eq.1) iskipi=-iskipi + if(jscan.eq.0) jskipi=-jskipi + ispec=0 ! SPECIAL CASE OF GLOBAL CYLINDRICAL GRID - if ((kgdso(1) .eq. 0 .or. kgdso(1) .eq. 4) .and. & - mod(kgdso(2), 2) .eq. 0 .and. kgdso(5) .eq. 0 .and. & - kgdso(11) .eq. 0) then - idrto = kgdso(1) - imo = kgdso(2) - jmo = kgdso(3) - rlon2 = kgdso(8)*1.e-3 - dlono = (mod(rlon2-1+3600, 360.)+1)/(imo-1) - igo = nint(360/abs(dlono)) - if (imo .eq. igo .and. idrto .eq. 0) then - rlat1 = kgdso(4)*1.e-3 - rlat2 = kgdso(7)*1.e-3 - dlat = (rlat2-rlat1)/(jmo-1) - jgo = nint(180/abs(dlat)) - if (jmo .eq. jgo) idrto = 256 - if (jmo .eq. jgo .or. jmo .eq. jgo+1) ispec = 1 - elseif (imo .eq. igo .and. idrto .eq. 4) then - jgo = kgdso(10)*2 - if (jmo .eq. jgo) ispec = 1 - end if - if (ispec .eq. 1) then - call sptrunv(iromb, maxwv, idrti, imaxi, jmaxi, idrto, imo, jmo, & - km, iprime, iskipi, jskipi, mi, 0, 0, mo, 0, ui, vi, & - .true., uo, vo, .false., dumm, dumm, .false., dumm, dumm) - end if + if((kgdso(1).eq.0.or.kgdso(1).eq.4).and. & + mod(kgdso(2),2).eq.0.and.kgdso(5).eq.0.and. & + kgdso(11).eq.0) then + idrto=kgdso(1) + imo=kgdso(2) + jmo=kgdso(3) + rlon2=kgdso(8)*1.e-3 + dlono=(mod(rlon2-1+3600,360.)+1)/(imo-1) + igo=nint(360/abs(dlono)) + if(imo.eq.igo.and.idrto.eq.0) then + rlat1=kgdso(4)*1.e-3 + rlat2=kgdso(7)*1.e-3 + dlat=(rlat2-rlat1)/(jmo-1) + jgo=nint(180/abs(dlat)) + if(jmo.eq.jgo) idrto=256 + if(jmo.eq.jgo.or.jmo.eq.jgo+1) ispec=1 + elseif(imo.eq.igo.and.idrto.eq.4) then + jgo=kgdso(10)*2 + if(jmo.eq.jgo) ispec=1 + endif + if(ispec.eq.1) then + call sptrunv(iromb,maxwv,idrti,imaxi,jmaxi,idrto,imo,jmo, & + km,iprime,iskipi,jskipi,mi,0,0,mo,0,ui,vi, & + .true.,uo,vo,.false.,dumm,dumm,.false.,dumm,dumm) + endif ! SPECIAL CASE OF POLAR STEREOGRAPHIC GRID - elseif (kgdso(1) .eq. 5 .and. & - kgdso(2) .eq. kgdso(3) .and. mod(kgdso(2), 2) .eq. 1 .and. & - kgdso(8) .eq. kgdso(9) .and. kgdso(11) .eq. 64 .and. & - mod(kgdso(6)/8, 2) .eq. 1) then - nps = kgdso(2) - rlat1 = kgdso(4)*1.e-3 - rlon1 = kgdso(5)*1.e-3 - orient = kgdso(7)*1.e-3 - xmesh = kgdso(8) - iproj = mod(kgdso(10)/128, 2) - ip = (nps+1)/2 - h = (-1.)**iproj - de = (1.+sin(60./dpr))*rerth - dr = de*cos(rlat1/dpr)/(1+h*sin(rlat1/dpr)) - xp = 1-h*sin((rlon1-orient)/dpr)*dr/xmesh - yp = 1+cos((rlon1-orient)/dpr)*dr/xmesh - if (nint(xp) .eq. ip .and. nint(yp) .eq. ip) then - if (iproj .eq. 0) then - call sptrunsv(iromb, maxwv, idrti, imaxi, jmaxi, km, nps, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, & - 60., xmesh, orient, ui, vi, .true., uo, vo, uo2, vo2, & - .false., dumm, dumm, dumm, dumm, & - .false., dumm, dumm, dumm, dumm) + elseif(kgdso(1).eq.5.and. & + kgdso(2).eq.kgdso(3).and.mod(kgdso(2),2).eq.1.and. & + kgdso(8).eq.kgdso(9).and.kgdso(11).eq.64.and. & + mod(kgdso(6)/8,2).eq.1) then + nps=kgdso(2) + rlat1=kgdso(4)*1.e-3 + rlon1=kgdso(5)*1.e-3 + orient=kgdso(7)*1.e-3 + xmesh=kgdso(8) + iproj=mod(kgdso(10)/128,2) + ip=(nps+1)/2 + h=(-1.)**iproj + de=(1.+sin(60./dpr))*rerth + dr=de*cos(rlat1/dpr)/(1+h*sin(rlat1/dpr)) + xp=1-h*sin((rlon1-orient)/dpr)*dr/xmesh + yp=1+cos((rlon1-orient)/dpr)*dr/xmesh + if(nint(xp).eq.ip.and.nint(yp).eq.ip) then + if(iproj.eq.0) then + call sptrunsv(iromb,maxwv,idrti,imaxi,jmaxi,km,nps, & + iprime,iskipi,jskipi,mi,mo,0,0,0, & + 60.,xmesh,orient,ui,vi,.true.,uo,vo,uo2,vo2, & + .false.,dumm,dumm,dumm,dumm, & + .false.,dumm,dumm,dumm,dumm) else - call sptrunsv(iromb, maxwv, idrti, imaxi, jmaxi, km, nps, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, & - 60., xmesh, orient, ui, vi, .true., uo2, vo2, uo, vo, & - .false., dumm, dumm, dumm, dumm, & - .false., dumm, dumm, dumm, dumm) - end if - ispec = 1 - end if + call sptrunsv(iromb,maxwv,idrti,imaxi,jmaxi,km,nps, & + iprime,iskipi,jskipi,mi,mo,0,0,0, & + 60.,xmesh,orient,ui,vi,.true.,uo2,vo2,uo,vo, & + .false.,dumm,dumm,dumm,dumm, & + .false.,dumm,dumm,dumm,dumm) + endif + ispec=1 + endif ! SPECIAL CASE OF MERCATOR GRID - elseif (kgdso(1) .eq. 1) then - ni = kgdso(2) - nj = kgdso(3) - rlat1 = kgdso(4)*1.e-3 - rlon1 = kgdso(5)*1.e-3 - rlon2 = kgdso(8)*1.e-3 - rlati = kgdso(9)*1.e-3 - iscano = mod(kgdso(11)/128, 2) - jscano = mod(kgdso(11)/64, 2) - nscano = mod(kgdso(11)/32, 2) - dy = kgdso(13) - hi = (-1.)**iscano - hj = (-1.)**(1-jscano) - dlono = hi*(mod(hi*(rlon2-rlon1)-1+3600, 360.)+1)/(ni-1) - dlato = hj*dy/(rerth*cos(rlati/dpr))*dpr - if (nscano .eq. 0) then - call sptrunmv(iromb, maxwv, idrti, imaxi, jmaxi, km, ni, nj, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, & - rlat1, rlon1, dlato, dlono, ui, vi, & - .true., uo, vo, .false., dumm, dumm, .false., dumm, dumm) - ispec = 1 - end if - end if + elseif(kgdso(1).eq.1) then + ni=kgdso(2) + nj=kgdso(3) + rlat1=kgdso(4)*1.e-3 + rlon1=kgdso(5)*1.e-3 + rlon2=kgdso(8)*1.e-3 + rlati=kgdso(9)*1.e-3 + iscano=mod(kgdso(11)/128,2) + jscano=mod(kgdso(11)/64,2) + nscano=mod(kgdso(11)/32,2) + dy=kgdso(13) + hi=(-1.)**iscano + hj=(-1.)**(1-jscano) + dlono=hi*(mod(hi*(rlon2-rlon1)-1+3600,360.)+1)/(ni-1) + dlato=hj*dy/(rerth*cos(rlati/dpr))*dpr + if(nscano.eq.0) then + call sptrunmv(iromb,maxwv,idrti,imaxi,jmaxi,km,ni,nj, & + iprime,iskipi,jskipi,mi,mo,0,0,0, & + rlat1,rlon1,dlato,dlono,ui,vi, & + .true.,uo,vo,.false.,dumm,dumm,.false.,dumm,dumm) + ispec=1 + endif + endif ! GENERAL SLOW CASE - if (ispec .eq. 0) then - call sptrungv(iromb, maxwv, idrti, imaxi, jmaxi, km, no, & - iprime, iskipi, jskipi, mi, mo, 0, 0, 0, rlat, rlon, & - ui, vi, .true., uo, vo, .false., dumm, dumm, .false., dumm, dumm) - do k = 1, km - ibo(k) = 0 - do n = 1, no - lo(n, k) = .true. - urot = crot(n)*uo(n, k)-srot(n)*vo(n, k) - vrot = srot(n)*uo(n, k)+crot(n)*vo(n, k) - uo(n, k) = urot - vo(n, k) = vrot - end do - end do - end if + if(ispec.eq.0) then + call sptrungv(iromb,maxwv,idrti,imaxi,jmaxi,km,no, & + iprime,iskipi,jskipi,mi,mo,0,0,0,rlat,rlon, & + ui,vi,.true.,uo,vo,.false.,dumm,dumm,.false.,dumm,dumm) + do k=1,km + ibo(k)=0 + do n=1,no + lo(n,k)=.true. + urot=crot(n)*uo(n,k)-srot(n)*vo(n,k) + vrot=srot(n)*uo(n,k)+crot(n)*vo(n,k) + uo(n,k)=urot + vo(n,k)=vrot + enddo + enddo + endif else - do k = 1, km - ibo(k) = 1 - do n = 1, no - lo(n, k) = .false. - uo(n, k) = 0. - vo(n, k) = 0. - end do - end do - end if - end subroutine polatev4_grib1 -end module spectral_interp_mod + do k=1,km + ibo(k)=1 + do n=1,no + lo(n,k)=.false. + uo(n,k)=0. + vo(n,k)=0. + enddo + enddo + endif + endsubroutine polatev4_grib1 +endmodule spectral_interp_mod