Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Better chem Mie table error checking #34

Merged
merged 7 commits into from
Mar 10, 2021
109 changes: 61 additions & 48 deletions Process_Library/Chem_MieTableMod2G.F90
Original file line number Diff line number Diff line change
Expand Up @@ -205,8 +205,10 @@ SUBROUTINE Chem_MieTableRead ( this, nch, channels, rc, nmom )

real :: yerr
integer :: nmom_, imom, ipol
integer :: status

#define NF_VERIFY_(expr) rc = expr; if (rc /= 0) return
#define __NF_STAT__ stat=status); NF_VERIFY_(status

rc = 0

Expand All @@ -227,7 +229,9 @@ SUBROUTINE Chem_MieTableRead ( this, nch, channels, rc, nmom )
! -------------------------------------
rc = nf_open(this%mietablename, NF_NOWRITE, ncid)
IF ( rc /= 0 ) THEN
! TODO: Should there be a return here?
print *, 'nf_open '//this%mietablename//' RETURN CODE=', rc
NF_VERIFY_(rc)
END IF

! RH
Expand All @@ -251,9 +255,10 @@ SUBROUTINE Chem_MieTableRead ( this, nch, channels, rc, nmom )
NF_VERIFY_(nf_inq_dimid(ncid,'nMom',idimid))
NF_VERIFY_(nf_inq_dimlen(ncid,idimid,nmom_table))
if ( nmom_ > nmom_table ) then
! TODO: Should rc be set to non-zero here?
! rc = 99
print*,'Error: nmom_ > nmom_table, see:'//myname
return
NF_VERIFY_(1)
end if
NF_VERIFY_(nf_inq_dimid(ncid,'nPol',idimid))
NF_VERIFY_(nf_inq_dimlen(ncid,idimid,nPol_table))
Expand All @@ -267,24 +272,25 @@ SUBROUTINE Chem_MieTableRead ( this, nch, channels, rc, nmom )
! bbck_table(nch_table,nrh_table,nbin_table), &
! g_table(nch_table,nrh_table,nbin_table), stat = rc )

allocate(channels_table(nch_table),stat = rc )
allocate(rh_table(nrh_table),stat = rc )
allocate(reff_table(nrh_table,nbin_table),stat = rc )
allocate(bext_table(nch_table,nrh_table,nbin_table),stat = rc )
allocate(bsca_table(nch_table,nrh_table,nbin_table),stat = rc )
allocate(bbck_table(nch_table,nrh_table,nbin_table), stat = rc )
! TODO: none of these stat=rc are being handled
allocate(channels_table(nch_table), __NF_STAT__)
allocate(rh_table(nrh_table), __NF_STAT__)
allocate(reff_table(nrh_table,nbin_table), __NF_STAT__)
allocate(bext_table(nch_table,nrh_table,nbin_table), __NF_STAT__)
allocate(bsca_table(nch_table,nrh_table,nbin_table), __NF_STAT__)
allocate(bbck_table(nch_table,nrh_table,nbin_table), __NF_STAT__)
allocate(g_table(nch_table,nrh_table,nbin_table), stat = rc )
allocate(pback_table(nch_table,nrh_table,nbin_table,nPol_table), stat = rc )
allocate(gf_table(nrh_table,nbin_table),stat = rc )
allocate(rhop_table(nrh_table,nbin_table),stat = rc )
allocate(rhod_table(nrh_table,nbin_table),stat = rc )
allocate(vol_table(nrh_table,nbin_table),stat = rc )
allocate(area_table(nrh_table,nbin_table),stat = rc )
allocate(refr_table(nch_table,nrh_table,nbin_table), stat = rc )
allocate(refi_table(nch_table,nrh_table,nbin_table), stat = rc )
allocate(pback_table(nch_table,nrh_table,nbin_table,nPol_table), __NF_STAT__)
allocate(gf_table(nrh_table,nbin_table), __NF_STAT__)
allocate(rhop_table(nrh_table,nbin_table), __NF_STAT__)
allocate(rhod_table(nrh_table,nbin_table), __NF_STAT__)
allocate(vol_table(nrh_table,nbin_table), __NF_STAT__)
allocate(area_table(nrh_table,nbin_table), __NF_STAT__)
allocate(refr_table(nch_table,nrh_table,nbin_table), __NF_STAT__)
allocate(refi_table(nch_table,nrh_table,nbin_table), __NF_STAT__)

if ( nmom_ > 0 ) then
allocate(pmom_table(nch_table,nrh_table,nbin_table,nmom_table,nPol_table), stat = rc )
allocate(pmom_table(nch_table,nrh_table,nbin_table,nmom_table,nPol_table), __NF_STAT__)
end if
NF_VERIFY_(nf_inq_varid(ncid,'lambda',ivarid))
NF_VERIFY_(nf_get_var_double(ncid,ivarid,channels_table))
Expand All @@ -301,6 +307,7 @@ SUBROUTINE Chem_MieTableRead ( this, nch, channels, rc, nmom )
NF_VERIFY_(nf_inq_varid(ncid,'rh',ivarid))
NF_VERIFY_(nf_get_var_double(ncid,ivarid,rh_table))

! TODO: we need to look at these NF_NOERR checks
! Get the backscatter phase function values
rc = nf_inq_varid(ncid,'pback',ivarid)
if(rc .ne. NF_NOERR) then ! pback not in table, fill in dummy variable
Expand Down Expand Up @@ -390,24 +397,25 @@ SUBROUTINE Chem_MieTableRead ( this, nch, channels, rc, nmom )
! this%g(this%nLambda,this%nrh,this%nbin), &
! stat = rc )

allocate (this%lambda(this%nLambda),stat = rc )
allocate (this%rh(this%nrh),stat = rc )
allocate (this%reff(this%nrh,this%nbin),stat = rc )
allocate (this%bext(this%nrh,this%nLambda,this%nbin),stat = rc )
allocate (this%bsca(this%nrh,this%nLambda,this%nbin),stat = rc )
allocate (this%bbck(this%nrh,this%nLambda,this%nbin),stat = rc )
allocate (this%g(this%nrh,this%nLambda,this%nbin), stat = rc )
allocate (this%pback(this%nrh,this%nLambda,this%nbin,this%nPol), stat = rc )
! TODO: none of these stat=rc are being handled
allocate (this%lambda(this%nLambda), __NF_STAT__)
allocate (this%rh(this%nrh), __NF_STAT__)
allocate (this%reff(this%nrh,this%nbin), __NF_STAT__)
allocate (this%bext(this%nrh,this%nLambda,this%nbin), __NF_STAT__)
allocate (this%bsca(this%nrh,this%nLambda,this%nbin), __NF_STAT__)
allocate (this%bbck(this%nrh,this%nLambda,this%nbin), __NF_STAT__)
allocate (this%g(this%nrh,this%nLambda,this%nbin), __NF_STAT__)
allocate (this%pback(this%nrh,this%nLambda,this%nbin,this%nPol), __NF_STAT__)
if ( nmom_ > 0 ) then
allocate (this%pmom(this%nrh,this%nLambda,this%nbin,this%nMom,this%nPol), stat = rc )
allocate (this%pmom(this%nrh,this%nLambda,this%nbin,this%nMom,this%nPol), __NF_STAT__)
end if
allocate (this%gf(this%nrh,this%nbin), stat = rc )
allocate (this%rhop(this%nrh,this%nbin), stat = rc )
allocate (this%rhod(this%nrh,this%nbin), stat = rc )
allocate (this%vol(this%nrh,this%nbin), stat = rc )
allocate (this%area(this%nrh,this%nbin), stat = rc )
allocate (this%refr(this%nrh,this%nLambda,this%nbin),stat = rc )
allocate (this%refi(this%nrh,this%nLambda,this%nbin),stat = rc )
allocate (this%gf(this%nrh,this%nbin), __NF_STAT__)
allocate (this%rhop(this%nrh,this%nbin), __NF_STAT__)
allocate (this%rhod(this%nrh,this%nbin), __NF_STAT__)
allocate (this%vol(this%nrh,this%nbin), __NF_STAT__)
allocate (this%area(this%nrh,this%nbin), __NF_STAT__)
allocate (this%refr(this%nrh,this%nLambda,this%nbin), __NF_STAT__)
allocate (this%refi(this%nrh,this%nLambda,this%nbin), __NF_STAT__)

! Preserve the full RH structure of the input table
this%rh(:) = rh_table(:)
Expand Down Expand Up @@ -491,24 +499,25 @@ SUBROUTINE Chem_MieTableRead ( this, nch, channels, rc, nmom )
! deallocate (channels_table, rh_table, bext_table, bsca_table, &
! bbck_table, g_table, stat = rc )

deallocate (channels_table, stat = rc )
deallocate (rh_table, stat = rc )
deallocate (reff_table, stat = rc )
deallocate (bext_table, stat = rc )
deallocate (bsca_table, stat = rc )
deallocate (bbck_table, stat = rc )
deallocate (g_table, stat = rc )
deallocate (pback_table, stat = rc )
! TODO: none of these stat=rc are being handled
deallocate (channels_table, __NF_STAT__)
deallocate (rh_table, __NF_STAT__)
deallocate (reff_table, __NF_STAT__)
deallocate (bext_table, __NF_STAT__)
deallocate (bsca_table, __NF_STAT__)
deallocate (bbck_table, __NF_STAT__)
deallocate (g_table, __NF_STAT__)
deallocate (pback_table, __NF_STAT__)
if ( nmom_ > 0 ) then
deallocate (pmom_table, stat = rc )
deallocate (pmom_table, __NF_STAT__)
endif
deallocate (gf_table, stat = rc )
deallocate (rhop_table, stat = rc )
deallocate (rhod_table, stat = rc )
deallocate (vol_table, stat = rc )
deallocate (area_table, stat = rc )
deallocate (refr_table, stat = rc )
deallocate (refi_table, stat = rc )
deallocate (gf_table, __NF_STAT__)
deallocate (rhop_table, __NF_STAT__)
deallocate (rhod_table, __NF_STAT__)
deallocate (vol_table, __NF_STAT__)
deallocate (area_table, __NF_STAT__)
deallocate (refr_table, __NF_STAT__)
deallocate (refi_table, __NF_STAT__)

return

Expand Down Expand Up @@ -635,6 +644,7 @@ impure elemental subroutine Chem_MieQueryByInt ( this, idx, channel, q_mass, rh,

character(len=*), parameter :: Iam = 'Chem_MieQuery'

! TODO: this rc seems to be doing nothing
if ( present(rc) ) rc = 0

ICHANNEL = nint(CHANNEL)
Expand Down Expand Up @@ -822,6 +832,7 @@ subroutine Chem_MieQueryByIntWithpmom ( this, idx, channel, q_mass, rh, &

character(len=*), parameter :: Iam = 'Chem_MieQueryByIntWithpmom'

! TODO: this rc seems to be doing nothing
if ( present(rc) ) rc = 0

ICHANNEL = nint(CHANNEL)
Expand All @@ -840,10 +851,12 @@ subroutine Chem_MieQueryByIntWithpmom ( this, idx, channel, q_mass, rh, &

! Now linearly interpolate the input table for the requested aerosol and
! channel; rh is the relative humidity.
! TODO: this rc is not beding handled.
call Chem_MieQuery ( this, idx, channel, q_mass, rh, &
tau, ssa, gasym, bext, bsca, bbck, &
reff, p11, p22, gf, rhop, rhod, &
vol, area, refr, refi, rc )
NF_VERIFY_(rc)

pmom(:,:) = TABLE%pmom(irh ,ichannel,TYPE,:,:) * (1.-arh) &
+ TABLE%pmom(irhp1,ichannel,TYPE,:,:) * arh
Expand Down