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

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
82 changes: 41 additions & 41 deletions fv_regrid_c2c.F90
Original file line number Diff line number Diff line change
Expand Up @@ -55,15 +55,15 @@ module fv_regrid_c2c
module procedure read_topo_file_r4
module procedure read_topo_file_r8
end interface

contains

subroutine read_topo_file_r4(fname,output,grid,rc)
character(len=*), intent(in) :: fname
type(ESMF_Grid), intent(in) :: grid
real(REAL32), intent(inout) :: output(:,:)
integer, intent(out), optional :: rc

integer :: status,dims(3),funit
integer :: rank
type(ESMF_VM) :: vm
Expand All @@ -89,7 +89,7 @@ subroutine read_topo_file_r8(fname,output,grid,rc)
type(ESMF_Grid), intent(in) :: grid
real(REAL64), intent(inout) :: output(:,:)
integer, intent(out), optional :: rc

integer :: status,dims(3),funit
real, allocatable :: input(:,:)
integer :: rank
Expand All @@ -104,7 +104,7 @@ subroutine read_topo_file_r8(fname,output,grid,rc)
open(newunit=funit,file=trim(fname),form='unformatted',iostat=status)
_VERIFY(status)
read(funit)input
input_r8 = input
input_r8 = input
else
allocate(input(0,0),input_r8(0,0))
end if
Expand Down Expand Up @@ -189,7 +189,7 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )
character(len=:), pointer :: var_name
type(StringVariableMap), pointer :: variables
type(Variable), pointer :: myVariable
type(StringVector) :: all_moist_vars
type(StringVector) :: all_moist_vars
type(StringVector), pointer :: var_dimensions
type(StringVectorIterator) :: siter
type(StringVector) :: moist_variables
Expand All @@ -211,7 +211,7 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )
isd_i = Atm_i(1)%bd%isd
ied_i = Atm_i(1)%bd%ied
jsd_i = Atm_i(1)%bd%jsd
jed_i = Atm_i(1)%bd%jed
jed_i = Atm_i(1)%bd%jed
is_i = Atm_i(1)%bd%is
ie_i = Atm_i(1)%bd%ie
js_i = Atm_i(1)%bd%js
Expand All @@ -228,9 +228,9 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )
jsd = Atm(1)%bd%jsd
jed = Atm(1)%bd%jed
is = Atm(1)%bd%is
ie = Atm(1)%bd%ie
js = Atm(1)%bd%js
je = Atm(1)%bd%je
ie = Atm(1)%bd%ie
js = Atm(1)%bd%js
je = Atm(1)%bd%je
ng = Atm(1)%ng

! Zero out all initial tracer fields:
Expand Down Expand Up @@ -265,7 +265,7 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )

if( is_master() ) then
print *
write(*,*) 'Input Vertical Grid'
write(*,*) 'Input Vertical Grid'
write(*,*) '--------------------'
write(6,100)
100 format(2x,' k ',' A(k) ',2x,' B(k) ',2x,' Pref ',2x,' DelP',/, &
Expand All @@ -283,7 +283,7 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )

! Read U
allocate ( u0(isd_i:ied_i,jsd_i:jed_i+1,km) )
u0(:,:,:) = 0.0
u0(:,:,:) = 0.0
do k=1,km
call MAPL_VarRead(formatter,"U",u0(is_i:ie_i,js_i:je_i,k),arrdes=Arrdes_i,lev=k)
enddo
Expand All @@ -304,7 +304,7 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )
sbufferx=sbuffer, nbufferx=nbuffer, &
gridtype=DGRID_NE )
do k=1,km
do i=is_i,ie_i
do i=is_i,ie_i
u0(i,je_i+1,k) = nbuffer(i,k)
enddo
do j=js_i,je_i
Expand Down Expand Up @@ -337,9 +337,9 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )
sbufferx=sbuffer, nbufferx=nbuffer, &
gridtype=DGRID_NE )
do k=1,km
do i=is,ie
do i=is,ie
ud(i,je+1,k) = nbuffer(i,k)
enddo
enddo
do j=js,je
vd(ie+1,j,k) = ebuffer(j,k)
enddo
Expand Down Expand Up @@ -388,7 +388,7 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )
enddo
call prt_maxmin('PT_geos', t0, is_i, ie_i, js_i, je_i, 0, km, 1.0_FVPRC)
call print_memuse_stats('get_geos_cubed_ic: read T')
! Read PE
! Read PE
allocate ( pe0(is_i:ie_i,js_i:je_i,km+1) )
do k=1,km+1
call MAPL_VarRead(formatter,"PE",pe0(is_i:ie_i,js_i:je_i,k),arrdes=Arrdes_i,lev=k)
Expand Down Expand Up @@ -433,7 +433,7 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )
call read_topo_file(fname1,gz0(is_i:ie_i,js_i:je_i),grid_i)
gz0 = gz0*grav

! Horiz Interp for surface pressure
! Horiz Interp for surface pressure
allocate( psc(is:ie,js:je) )
call prt_maxmin('PS_geos', ps0, is_i, ie_i, js_i, je_i, 0, 1, 1.0_FVPRC)
call regridder%regrid(ps0(is_i:ie_i,js_i:je_i),psc(is:ie,js:je),rc=status)
Expand Down Expand Up @@ -477,7 +477,7 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )
if (ndims == 3) call moist_variables%push_back(trim(var_name))
call siter%next()
enddo
if (moist_variables%size() /= atm(1)%ncnst) call mpp_error(FATAL,'Wrong number of variables in moist file')
if (moist_variables%size() /= atm(1)%ncnst) call mpp_error(FATAL,'Wrong number of variables in moist file')

lvar_cnt=0
do ivar=1,Atm(1)%ncnst
Expand Down Expand Up @@ -545,15 +545,15 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )
do i=1,size(extra_rst)
do j=1,size(extra_rst(i)%vars)
if (extra_rst(i)%vars(j)%nLev/=1) then
if (extra_rst(i)%vars(j)%nLev == npz) then
if (extra_rst(i)%vars(j)%nLev == npz) then
tracer_bundles(i)%vars(j)%nLev=km
call tracer_bundles(i)%vars(j)%alloc_var(is,ie,js,je,km)
else if (extra_rst(i)%vars(j)%nLev == npz+1) then
tracer_bundles(i)%vars(j)%nLev=km+1
call tracer_bundles(i)%vars(j)%alloc_var(is,ie,js,je,km+1)
end if
end if
else
call tracer_bundles(i)%vars(j)%alloc_Var(is,ie,js,je)
call tracer_bundles(i)%vars(j)%alloc_Var(is,ie,js,je)
end if
enddo
enddo
Expand Down Expand Up @@ -589,7 +589,7 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )
do n_ungrid=1,tracer_bundles(ifile)%vars(ivar)%n_ungrid
do k=1,nlev
call MAPL_VarRead(formatter,vname,qlev(is_i:ie_i,js_i:je_i),arrdes=Arrdes_i,lev=k,offset2=n_ungrid)
q0(is_i:ie_i,js_i:je_i,k) = qlev(is_i:ie_i,js_i:je_i)
q0(is_i:ie_i,js_i:je_i,k) = qlev(is_i:ie_i,js_i:je_i)
call regridder%regrid(qlev(is_i:ie_i,js_i:je_i),tracer_bundles(ifile)%vars(ivar)%ptr4d(is:ie,js:je,k,n_ungrid),rc=status)
enddo
call prt_maxmin( trim(vname)//'_geos_'//trim(tracer_bundles(ifile)%file_name), q0, is_i, ie_i, js_i, je_i, 0, nlev, 1._FVPRC)
Expand All @@ -603,7 +603,7 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )

enddo
deallocate ( q0 )

if (is_master()) print*, ''
if (is_master()) print*, 'Vertical Remapping: '
! Vert remap for scalars
Expand Down Expand Up @@ -649,12 +649,12 @@ subroutine get_geos_cubed_ic( Atm_i, Atm, grid_i, grid, Arrdes_i, extra_rst )

! Range check the MOIST tracers
! Iterate over tracer names

iter = moist_tracers%begin()
do while (iter /= moist_tracers%end())
iptr => iter%value()
cptr => iter%key()
if (.not.match(cptr)) then
if (.not.match(cptr)) then
do k=1,npz
do j=js,je
do i=is,ie
Expand Down Expand Up @@ -730,7 +730,7 @@ subroutine remap_winds(is,ie, js, je, isd,ied, jsd,jed, km, npz, ak0, bk0, psc,
enddo
enddo
enddo
call mpp_update_domains(pe0, Atm%domain)
call mpp_update_domains(pe0, Atm%domain)

do k=1,npz+1
do j=js,je
Expand All @@ -753,17 +753,17 @@ subroutine remap_winds(is,ie, js, je, isd,ied, jsd,jed, km, npz, ak0, bk0, psc,
enddo
do k=1,km
do i=is,ie
dpe0(i,k) = pe0d(i,k+1)-pe0d(i,k)
dpe0(i,k) = pe0d(i,k+1)-pe0d(i,k)
enddo
enddo
do k=1,npz+1
do i=is,ie
pe1d(i,k) = 0.5*(pe1(i,j-1,k)+pe1(i,j,k))
pe1d(i,k) = 0.5*(pe1(i,j-1,k)+pe1(i,j,k))
enddo
enddo
do k=1,npz
do i=is,ie
dpe1(i,k) = pe1d(i,k+1)-pe1d(i,k)
dpe1(i,k) = pe1d(i,k+1)-pe1d(i,k)
enddo
enddo
call map_scalar( km, pe0d, ud(is:ie,j,1:km), &
Expand All @@ -790,12 +790,12 @@ subroutine remap_winds(is,ie, js, je, isd,ied, jsd,jed, km, npz, ak0, bk0, psc,
enddo
do k=1,npz+1
do i=is,ie
pe1d(i,k) = 0.5*(pe1(i-1,j,k)+pe1(i,j,k))
pe1d(i,k) = 0.5*(pe1(i-1,j,k)+pe1(i,j,k))
enddo
enddo
do k=1,npz
do i=is,ie
dpe1(i,k) = pe1d(i,k+1)-pe1d(i,k)
dpe1(i,k) = pe1d(i,k+1)-pe1d(i,k)
enddo
enddo
call map_scalar( km, pe0d, vd(is:ie,j,1:km), &
Expand Down Expand Up @@ -824,14 +824,14 @@ end subroutine remap_winds
subroutine xyz_to_dgrid(v3, ud, vd, npx, npy, is, ie, js, je, isd, ied, jsd, jed, gridstruct)

! Move A-Grid xyz winds to the D-grid cubed-sphere orientation

! !INPUT/OUTPUT PARAMETERS:
integer, intent(in) :: npx, npy, is, ie, js, je, isd, ied, jsd, jed
real(REAL64) :: v3(3, isd:ied ,jsd:jed )
real(FVPRC), intent(inout) :: ud(isd:ied,jsd:jed+1) ! U-Wind
real(FVPRC), intent(inout) :: vd(isd:ied+1,jsd:jed) ! V-Wind
type(fv_grid_type), intent(IN), target :: gridstruct
! !Local Variables
! !Local Variables
integer :: i,j, im2,jm2

real(REAL64) :: ue(is-1:ie+1,js :je+1,3) ! 3D winds at edges
Expand Down Expand Up @@ -941,14 +941,14 @@ subroutine xyz_to_dgrid(v3, ud, vd, npx, npy, is, ie, js, je, isd, ied, jsd, jed
do i=is,ie
ud(i,j) = ue(i,j,1)*gridstruct%es(1,i,j,1) + &
ue(i,j,2)*gridstruct%es(2,i,j,1) + &
ue(i,j,3)*gridstruct%es(3,i,j,1)
ue(i,j,3)*gridstruct%es(3,i,j,1)
enddo
enddo
do j=js,je
do i=is,ie+1
vd(i,j) = ve(i,j,1)*gridstruct%ew(1,i,j,2) + &
ve(i,j,2)*gridstruct%ew(2,i,j,2) + &
ve(i,j,3)*gridstruct%ew(3,i,j,2)
ve(i,j,3)*gridstruct%ew(3,i,j,2)
enddo
enddo

Expand All @@ -961,11 +961,11 @@ subroutine d2a2d(ui, vi, uo, vo, Atm_i, Atm, regridder)

class(AbstractRegridder), pointer :: regridder

real(REAL32), dimension(Atm_i%bd%isd:Atm_i%bd%ied ,Atm_i%bd%jsd:Atm_i%bd%jed+1), intent(in) :: ui
real(REAL32), dimension(Atm_i%bd%isd:Atm_i%bd%ied+1,Atm_i%bd%jsd:Atm_i%bd%jed ), intent(in) :: vi
real(FVPRC), dimension(Atm_i%bd%isd:Atm_i%bd%ied ,Atm_i%bd%jsd:Atm_i%bd%jed+1), intent(in) :: ui
real(FVPRC), dimension(Atm_i%bd%isd:Atm_i%bd%ied+1,Atm_i%bd%jsd:Atm_i%bd%jed ), intent(in) :: vi

real(REAL32), dimension(Atm%bd%isd:Atm%bd%ied ,Atm%bd%jsd:Atm%bd%jed+1), intent(inout) :: uo
real(REAL32), dimension(Atm%bd%isd:Atm%bd%ied+1,Atm%bd%jsd:Atm%bd%jed ), intent(inout) :: vo
real(FVPRC), dimension(Atm%bd%isd:Atm%bd%ied ,Atm%bd%jsd:Atm%bd%jed+1), intent(inout) :: uo
real(FVPRC), dimension(Atm%bd%isd:Atm%bd%ied+1,Atm%bd%jsd:Atm%bd%jed ), intent(inout) :: vo

!------------------------------------------------------------------!
! local variables !
Expand Down Expand Up @@ -1034,7 +1034,7 @@ subroutine d2a2d(ui, vi, uo, vo, Atm_i, Atm, regridder)
tmp_i = va_xyz_i(n,:,:)
call regridder%regrid(tmp_i( is: ie, js: je), &
tmp_o(Atm%bd%is:Atm%bd%ie,Atm%bd%js:Atm%bd%je), rc=status)
call mpp_update_domains(tmp_o, Atm%domain)
call mpp_update_domains(tmp_o, Atm%domain)
va_xyz_o(n,:,:) = tmp_o
enddo
!------------------------------------------------------------!
Expand All @@ -1046,6 +1046,6 @@ subroutine d2a2d(ui, vi, uo, vo, Atm_i, Atm, regridder)
Atm%gridstruct)

end subroutine d2a2d

end module fv_regrid_c2c

22 changes: 11 additions & 11 deletions interp_restarts.F90
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,7 @@ program interp_restarts
! to the cubed-sphere grid with optional vertical levels !
!--------------------------------------------------------------------!
use ESMF
use MAPL
use MAPL
use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_root_pe, mpp_broadcast
use fms_mod, only: print_memory_usage, fms_init, fms_end, file_exist
use fv_control_mod, only: fv_init1, fv_init2, fv_end
Expand Down Expand Up @@ -308,7 +308,7 @@ program interp_restarts
if( is_master() ) then
print *
write(*,*) 'Output Vertical Grid'
write(*,*) '--------------------'
write(*,*) '--------------------'
write(6,100)
100 format(2x,' k ',' A(k) ',2x,' B(k) ',2x,' Pref ',2x,' DelP',/, &
1x,'----',3x,'----------',2x,'--------',2x,'----------',2x,'---------' )
Expand Down Expand Up @@ -528,7 +528,7 @@ program interp_restarts
! PT
if (is_master()) print*, 'Writing : ', TRIM(fname1), ' PT'
r4_local(is:ie,js:je,1:npz) = pt_local
call prt_mxm('PT', r4_local, is, ie, js, je, 0, npz, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
call prt_mxm('PT', real(r4_local, kind=FVPRC), is, ie, js, je, 0, npz, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
call MAPL_VarWrite(OutFmt,"PT",pt_local(is:ie,js:je,1:npz),arrdes=arrdes,rc=status)
VERIFY_(status)

Expand All @@ -537,7 +537,7 @@ program interp_restarts
do k=1,npz+1
r4_local(is:ie,js:je,k)= Atm(1)%pe(is:ie,k,js:je)
enddo
call prt_mxm('PE', r4_local, is, ie, js, je, 0, npz+1, 1.0, Atm(1)%gridstruct%area_64, Atm(1)%domain)
call prt_mxm('PE', real(r4_local, kind=FVPRC), is, ie, js, je, 0, npz+1, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
do k=1,npz+1
r8_local(is:ie,js:je,k) = Atm(1)%pe(is:ie,k,js:je)
enddo
Expand All @@ -546,7 +546,7 @@ program interp_restarts
! PKZ
if (is_master()) print*, 'Writing : ', TRIM(fname1), ' PKZ'
r4_local(is:ie,js:je,1:npz) = Atm(1)%pkz(is:ie,js:je,1:npz)
call prt_mxm('PKZ', r4_local, is, ie, js, je, 0, npz, 1.0, Atm(1)%gridstruct%area_64, Atm(1)%domain)
call prt_mxm('PKZ', real(r4_local, kind=FVPRC), is, ie, js, je, 0, npz, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
r8_local(is:ie,js:je,1:npz) = Atm(1)%pkz(is:ie,js:je,1:npz)
call MAPL_VarWrite(OutFmt,"PKZ",r8_local(is:ie,js:je,1:npz),arrdes=arrdes,rc=status)
VERIFY_(status)
Expand All @@ -555,15 +555,15 @@ program interp_restarts
! DZ
if (is_master()) print*, 'Writing : ', TRIM(fname1), ' DZ'
r4_local(is:ie,js:je,1:npz) = Atm(1)%delz(is:ie,js:je,1:npz)
call prt_mxm('DZ', r4_local, is, ie, js, je, 0, npz, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
call prt_mxm('DZ', real(r4_local, kind=FVPRC), is, ie, js, je, 0, npz, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
r8_local(is:ie,js:je,1:npz) = Atm(1)%delz(is:ie,js:je,1:npz)
call MAPL_VarWrite(OutFmt,"DZ",r8_local(is:ie,js:je,1:npz),arrdes=arrdes,rc=status)
VERIFY_(status)

! W
if (is_master()) print*, 'Writing : ', TRIM(fname1), ' W'
r4_local(is:ie,js:je,1:npz) = Atm(1)%w(is:ie,js:je,1:npz)
call prt_mxm('W', r4_local, is, ie, js, je, 0, npz, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
call prt_mxm('W', real(r4_local, kind=FVPRC), is, ie, js, je, 0, npz, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
r8_local(is:ie,js:je,1:npz) = Atm(1)%w(is:ie,js:je,1:npz)
call MAPL_VarWrite(OutFmt,"W",r8_local(is:ie,js:je,1:npz),arrdes=arrdes,rc=status)
VERIFY_(status)
Expand Down Expand Up @@ -649,7 +649,7 @@ program interp_restarts
lcnt_var=lcnt_var+1
end if
r4_local(is:ie,js:je,1:npz) = Atm(1)%q(is:ie,js:je,:,iq0)
call prt_mxm(trim(var_name), r4_local, is, ie, js, je, 0, npz, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
call prt_mxm(trim(var_name), real(r4_local, kind=FVPRC), is, ie, js, je, 0, npz, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
call MAPL_VarWrite(OutFmt,triM(var_name),r4_local(is:ie,js:je,1:npz),arrdes=arrdes,rc=status)
VERIFY_(status)
end if
Expand Down Expand Up @@ -708,11 +708,11 @@ program interp_restarts
allocate(r4_local(is:ie,js:je,nlev))
if (rst_files(ifile)%vars(iq)%rank ==2) then
r4_local2d(is:ie,js:je)=rst_files(ifile)%vars(iq)%ptr2d(is:ie,js:je)
call prt_mxm(trim(vname), r4_local2d, is, ie, js, je, 0, 1, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
call prt_mxm(trim(vname), real(r4_local2d, kind=FVPRC), is, ie, js, je, 0, 1, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
call MAPL_VarWrite(OutFmt,vname,r4_local2d(is:ie,js:je),arrdes=arrdes)
else if (rst_files(ifile)%vars(iq)%rank ==3) then
r4_local(is:ie,js:je,1:nlev)=rst_files(ifile)%vars(iq)%ptr3d(is:ie,js:je,1:nlev)
call prt_mxm(trim(vname), r4_local, is, ie, js, je, 0, nlev, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
call prt_mxm(trim(vname), real(r4_local, kind=FVPRC), is, ie, js, je, 0, nlev, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
call MAPL_VarWrite(OutFmt,vname,r4_local(is:ie,js:je,1:nlev),arrdes)
else if (rst_files(ifile)%vars(iq)%rank ==4) then
do n=1,size(rst_files(ifile)%vars(iq)%ptr4d,4)
Expand All @@ -722,7 +722,7 @@ program interp_restarts
call MAPL_VarWrite(OutFmt,vname,r4_local2d(is:ie,js:je),arrdes=arrdes,lev=k,offset2=n)
if (k<=npz) r4_local(is:ie,js:je,k) = r4_local2d(is:ie,js:je)
enddo
call prt_mxm(trim(vname), r4_local, is, ie, js, je, 0, npz, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
call prt_mxm(trim(vname), real(r4_local, kind=FVPRC), is, ie, js, je, 0, npz, 1.0_FVPRC, Atm(1)%gridstruct%area_64, Atm(1)%domain)
enddo
end if
end do
Expand Down
Loading