Skip to content

Commit

Permalink
yet more changes needed by NCAR#136
Browse files Browse the repository at this point in the history
  • Loading branch information
@SamuelTrahanNOAA
SamuelTrahanNOAA committed Dec 13, 2023
1 parent 93c14c8 commit c6dcaa6
Show file tree
Hide file tree
Showing 4 changed files with 80 additions and 69 deletions.
21 changes: 6 additions & 15 deletions physics/GFS_phys_time_vary.fv3.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,8 +16,8 @@ module GFS_phys_time_vary

use module_ozphys, only: ty_ozphys

use h2o_def, only : levh2o, h2o_coeff, h2o_lat, h2o_pres, h2o_time, h2oplin
use h2ointerp, only : read_h2odata, setindxh2o, h2ointerpol
use h2o_def, only: levh2o, h2o_coeff
use h2ointerp, only : free_h2odata, read_h2odata, setindxh2o, h2ointerpol

use aerclm_def, only : aerin, aer_pres, ntrcaer, ntrcaerm, iamin, iamax, jamin, jamax
use aerinterp, only : read_aerdata, setindxaer, aerinterpol, read_aerdataf
Expand All @@ -27,8 +27,7 @@ module GFS_phys_time_vary

use gcycle_mod, only : gcycle

use cires_tauamf_data, only: cires_indx_ugwp, read_tau_amf, tau_amf_interp
use cires_tauamf_data, only: tau_limb, days_limb, ugwp_taulat
use cires_tauamf_data, only: free_tau_amf, cires_indx_ugwp, read_tau_amf, tau_amf_interp

!--- variables needed for calculating 'sncovr'
use namelist_soilveg, only: salp_data, snupx
Expand Down Expand Up @@ -225,7 +224,7 @@ subroutine GFS_phys_time_vary_init (
!$OMP parallel num_threads(nthrds) default(none) &
!$OMP shared (me,master,ntoz,h2o_phys,im,nx,ny,levs,idate) &
!$OMP shared (xlat_d,xlon_d,imap,jmap,errmsg,errflg) &
!$OMP shared (levh2o,h2o_coeff,h2o_pres,h2opl) &
!$OMP shared (h2opl, levh2o, h2o_coeff) &
!$OMP shared (iamin, iamax, jamin, jamax, lsm_noahmp) &
!$OMP shared (iaerclm,iaermdl,ntrcaer,aer_nm,iflip,iccn) &
!$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) &
Expand Down Expand Up @@ -1048,12 +1047,6 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg)

if (.not.is_initialized) return

! Deallocate h2o arrays
if (allocated(h2o_lat) ) deallocate(h2o_lat)
if (allocated(h2o_pres)) deallocate(h2o_pres)
if (allocated(h2o_time)) deallocate(h2o_time)
if (allocated(h2oplin) ) deallocate(h2oplin)

! Deallocate aerosol arrays
if (allocated(aerin) ) deallocate(aerin)
if (allocated(aer_pres)) deallocate(aer_pres)
Expand All @@ -1063,10 +1056,8 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg)
if (allocated(ccnin) ) deallocate(ccnin)
if (allocated(ci_pres) ) deallocate(ci_pres)

! Deallocate UGWP-input arrays
! if (allocated(ugwp_taulat)) deallocate(ugwp_taulat)
! if (allocated(tau_limb )) deallocate(tau_limb)
! if (allocated(days_limb )) deallocate(days_limb)
call free_h2odata
call free_tau_amf

is_initialized = .false.

Expand Down
80 changes: 46 additions & 34 deletions physics/cires_tauamf_data.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,18 +6,34 @@ module cires_tauamf_data
!...........................................................................................
implicit none

integer :: ntau_d1y, ntau_d2t
real(kind=kind_phys), pointer :: ugwp_taulat(:) => null()
real(kind=kind_phys), pointer :: tau_limb(:,:) => null()
real(kind=kind_phys), pointer :: days_limb(:) => null()
logical :: flag_alloctau = .false.
character(len=255):: ugwp_taufile = 'ugwp_limb_tau.nc'
character(len=255), parameter:: ugwp_taufile = 'ugwp_limb_tau.nc'

public :: read_tau_amf, cires_indx_ugwp, tau_amf_interp
private
public :: free_tau_amf, read_tau_amf, cires_indx_ugwp, tau_amf_interp

contains


subroutine free_tau_amf
implicit none
if(associated(ugwp_taulat)) then
deallocate(ugwp_taulat)
nullify(ugwp_taulat)
endif

if(associated(days_limb)) then
deallocate(days_limb)
nullify(days_limb)
endif

if(associated(tau_limb)) then
deallocate(tau_limb)
nullify(tau_limb)
endif
end subroutine free_tau_amf

logical function netcdf_check(status, errmsg, errflg, why)
use netcdf
implicit none
Expand Down Expand Up @@ -50,6 +66,7 @@ subroutine read_tau_amf(me, master, errmsg, errflg)
character(len=*), intent(out) :: errmsg
integer, intent(out) :: errflg
!
integer :: ntau_d1y, ntau_d2t
write(0,*) 'read_tau_amf'

ntau_d1y = 0
Expand Down Expand Up @@ -96,7 +113,7 @@ subroutine read_tau_amf(me, master, errmsg, errflg)
allocate(local_days_limb(ntau_d2t))
allocate(local_tau_limb(ntau_d1y, ntau_d2t))

call free_globals
call free_tau_amf

allocate(ugwp_taulat(ntau_d1y))
allocate(days_limb(ntau_d2t))
Expand Down Expand Up @@ -154,26 +171,9 @@ subroutine free_locals
deallocate(local_tau_limb)
end subroutine free_locals

subroutine free_globals
if(associated(ugwp_taulat)) then
deallocate(ugwp_taulat)
nullify(ugwp_taulat)
endif

if(associated(days_limb)) then
deallocate(days_limb)
nullify(days_limb)
endif

if(associated(tau_limb)) then
deallocate(tau_limb)
nullify(tau_limb)
endif
end subroutine free_globals

subroutine cleanup
call free_locals
call free_globals
call free_tau_amf
end subroutine cleanup

end subroutine read_tau_amf
Expand All @@ -195,17 +195,23 @@ subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j

!locals

integer :: i,j, j1, j2
integer :: i,j, j1, j2, ntau_d1y
!

ntau_d1y = size(ugwp_taulat)
errmsg = ' '
errflg = 0

if(ntau_d1y<1 .or. ntau_d1y>4000) then
errmsg = 'corrupted ntau_d1y (lat) dimension'
errflg = 1
return
endif
if(size(dlat)/=npts .or. size(w1_j1tau)/=npts .or. size(w2_j2tau)/=npts .or. size(j1_tau)/=npts .or. size(j2_tau)/=npts) then
errmsg = 'mismatch in argument array sizes'
errflg = 1
return
endif

if(ntau_d1y<1 .or. ntau_d1y>4000 .or. ntau_d1y/=size(ugwp_taulat) .or. ntau_d1y/=size(tau_limb,1)) then
errmsg = 'corrupted ntau_d1y (lat) dimension'
errflg = 1
return
endif

do j=1,npts
j2_tau(j) = ntau_d1y
Expand Down Expand Up @@ -248,19 +254,25 @@ subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, d
character(*), intent(out) :: errmsg
!locals

integer :: i, j1, j2, it1, it2 , iday
integer :: i, j1, j2, it1, it2 , iday, ntau_d2t
integer :: ddd
real(kind=kind_phys) :: tx1, tx2, w1, w2, fddd
!
! define day of year ddd ..... from the old-fashioned "GFS-style"
!
ddd = 1e9
fddd = 1e9

ntau_d2t = size(days_limb)
errmsg = ' '
errflg = 0

if(ntau_d2t<1 .or. ntau_d2t>366) then
if(size(ddy_j1)/=im .or. size(ddy_j2)/=im .or. size(j1_tau)/=im .or. size(j2_tau)/=im .or. size(tau_ddd)/=im) then
errmsg = 'mismatch in argument array sizes'
errflg = 1
return
endif

if(ntau_d2t<1 .or. ntau_d2t>366 .or. ntau_d2t/=size(days_limb) .or. ntau_d2t/=size(tau_limb,2)) then
errmsg = 'corrupted ntau_d2t (days) dimension'
errflg = 1
return
Expand Down
11 changes: 3 additions & 8 deletions physics/h2o_def.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,12 +11,7 @@ module h2o_def

use machine , only : kind_phys
implicit none

integer, parameter :: kh2opltc=29

integer latsh2o, levh2o, timeh2o, h2o_coeff
real (kind=kind_phys), allocatable :: h2o_lat(:), h2o_pres(:)
&, h2o_time(:)
real (kind=kind_phys), allocatable :: h2oplin(:,:,:,:)

private
integer, public :: levh2o=-1, h2o_coeff=-1
real(kind=kind_phys), allocatable, public :: h2o_pres(:)
end module h2o_def
37 changes: 25 additions & 12 deletions physics/h2ointerp.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,18 +6,33 @@
!> This module contains subroutines of reading and interpolating
!! h2o coefficients.
module h2ointerp

use machine, only: kind_phys
use h2o_def, only: levh2o, h2o_coeff, h2o_pres
implicit none

private

public :: read_h2odata, setindxh2o, h2ointerpol
integer, parameter :: kh2opltc=29

integer :: latsh2o=-1, timeh2o=-1
real (kind=kind_phys), allocatable :: h2o_lat(:), h2o_time(:)
real (kind=kind_phys), allocatable :: h2oplin(:,:,:,:)

public :: read_h2odata, setindxh2o, h2ointerpol, free_h2odata

contains

subroutine free_h2odata
implicit none
if(allocated(h2o_lat)) deallocate(h2o_lat)
if(allocated(h2o_pres)) deallocate(h2o_pres)
if(allocated(h2o_time)) deallocate(h2o_time)
if(allocated(h2oplin)) deallocate(h2oplin)
end subroutine free_h2odata

subroutine read_h2odata (h2o_phys, me, master)
use machine, only: kind_phys
use h2o_def
implicit none
!--- in/out
logical, intent(in) :: h2o_phys
integer, intent(in) :: me
Expand Down Expand Up @@ -91,26 +106,25 @@ subroutine setindxh2o(npts,dlat,jindx1,jindx2,ddy)
! May 2015 Shrinivas Moorthi - Prepare for H2O interpolation
!
use machine, only: kind_phys
use h2o_def, only: jh2o => latsh2o, h2o_lat, h2o_time
!
implicit none
!
integer npts
integer, dimension(npts) :: jindx1, jindx2
real(kind=kind_phys) :: dlat(npts),ddy(npts)
integer, dimension(:) :: jindx1, jindx2
real(kind=kind_phys) :: dlat(:),ddy(:)
!
integer i,j,lat
!
do j=1,npts
jindx2(j) = jh2o + 1
do i=1,jh2o
jindx2(j) = latsh2o + 1
do i=1,latsh2o
if (dlat(j) < h2o_lat(i)) then
jindx2(j) = i
exit
endif
enddo
jindx1(j) = max(jindx2(j)-1,1)
jindx2(j) = min(jindx2(j),jh2o)
jindx2(j) = min(jindx2(j),latsh2o)
if (jindx2(j) /= jindx1(j)) then
ddy(j) = (dlat(j) - h2o_lat(jindx1(j))) &
/ (h2o_lat(jindx2(j)) - h2o_lat(jindx1(j)))
Expand All @@ -132,7 +146,6 @@ subroutine h2ointerpol(me,npts,idate,fhour,jindx1,jindx2,h2oplout,ddy)
! May 2015 Shrinivas Moorthi - Prepare for H2O interpolation
!
use machine , only : kind_phys
use h2o_def
implicit none
integer j,j1,j2,l,npts,nc,n1,n2
real(kind=kind_phys) fhour,tem, tx1, tx2
Expand All @@ -142,8 +155,8 @@ subroutine h2ointerpol(me,npts,idate,fhour,jindx1,jindx2,h2oplout,ddy)
integer me,idate(4)
integer idat(8),jdat(8)
!
real(kind=kind_phys) ddy(npts)
real(kind=kind_phys) h2oplout(npts,levh2o,h2o_coeff)
real(kind=kind_phys) ddy(:)
real(kind=kind_phys) h2oplout(:,:,:)
real(kind=kind_phys) rjday
integer jdow, jdoy, jday
real(8) rinc(5)
Expand Down

0 comments on commit c6dcaa6

Please sign in to comment.