diff --git a/Process_Library/Chem_MieTableMod2G.F90 b/Process_Library/Chem_MieTableMod2G.F90 index d9db51e9..2fc9514e 100644 --- a/Process_Library/Chem_MieTableMod2G.F90 +++ b/Process_Library/Chem_MieTableMod2G.F90 @@ -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 @@ -228,6 +230,7 @@ SUBROUTINE Chem_MieTableRead ( this, nch, channels, rc, nmom ) rc = nf_open(this%mietablename, NF_NOWRITE, ncid) IF ( rc /= 0 ) THEN print *, 'nf_open '//this%mietablename//' RETURN CODE=', rc + NF_VERIFY_(rc) END IF ! RH @@ -253,7 +256,7 @@ SUBROUTINE Chem_MieTableRead ( this, nch, channels, rc, nmom ) if ( nmom_ > nmom_table ) then ! 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)) @@ -267,24 +270,24 @@ 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 ) + 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)) @@ -301,6 +304,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 @@ -390,24 +394,24 @@ 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 ) + 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(:) @@ -491,24 +495,24 @@ 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 ) + 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 @@ -844,6 +848,7 @@ subroutine Chem_MieQueryByIntWithpmom ( 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