diff --git a/Process_Library/GOCART2G_MieMod.F90 b/Process_Library/GOCART2G_MieMod.F90 index 572963d7..16801e44 100644 --- a/Process_Library/GOCART2G_MieMod.F90 +++ b/Process_Library/GOCART2G_MieMod.F90 @@ -156,6 +156,7 @@ type(GOCART2G_Mie) function GOCART2G_MieCreate ( MieFile, wavelengths, nmom, rc real :: yerr integer :: nmom_, imom, ipol + real, allocatable, dimension(:) :: real_tmp, bext_tmp, bsca_tmp, bbck_tmp, g_tmp,refr_tmp, refi_tmp integer :: status #define NF_VERIFY_(expr) rc = expr; if (rc /= 0) return @@ -193,7 +194,7 @@ type(GOCART2G_Mie) function GOCART2G_MieCreate ( MieFile, wavelengths, nmom, rc ! Channels ! -------- - NF_VERIFY_(nf90_inq_dimid(ncid,'lambda',idimid)) + NF_VERIFY_(nf90_inq_dimid(ncid,'wavelength',idimid)) NF_VERIFY_(nf90_inquire_dimension(ncid,idimid,len=nch_table)) if (present(wavelengths) ) then @@ -204,20 +205,20 @@ type(GOCART2G_Mie) function GOCART2G_MieCreate ( MieFile, wavelengths, nmom, rc ! Dry Effective radius ! -------------------- - NF_VERIFY_(nf90_inq_dimid(ncid,'radius',idimid)) + NF_VERIFY_(nf90_inq_dimid(ncid,'bin',idimid)) NF_VERIFY_(nf90_inquire_dimension(ncid,idimid,len=nbin_table)) ! Moments of phase function ! ------------------------- if ( nmom_ > 0 ) then - NF_VERIFY_(nf90_inq_dimid(ncid,'nMom',idimid)) + NF_VERIFY_(nf90_inq_dimid(ncid,'m',idimid)) NF_VERIFY_(nf90_inquire_dimension(ncid,idimid,len=nmom_table)) if ( nmom_ > nmom_table ) then ! rc = 99 print*,'Error: nmom_ > nmom_table, see:'//myname NF_VERIFY_(1) end if - NF_VERIFY_(nf90_inq_dimid(ncid,'nPol',idimid)) + NF_VERIFY_(nf90_inq_dimid(ncid,'p',idimid)) NF_VERIFY_(nf90_inquire_dimension(ncid,idimid,len=nPol_table)) endif @@ -227,21 +228,21 @@ type(GOCART2G_Mie) function GOCART2G_MieCreate ( MieFile, wavelengths, nmom, 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), __NF_STAT__) + allocate(bext_table(nrh_table,nch_table,nbin_table), __NF_STAT__) + allocate(bsca_table(nrh_table,nch_table,nbin_table), __NF_STAT__) + allocate(bbck_table(nrh_table,nch_table,nbin_table), __NF_STAT__) + allocate(g_table(nrh_table,nch_table,nbin_table), stat = rc ) + allocate(pback_table(nPol_table,nrh_table,nch_table,nbin_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__) + allocate(refr_table(nrh_table,nch_table,nbin_table), __NF_STAT__) + allocate(refi_table(nrh_table,nch_table,nbin_table), __NF_STAT__) if ( nmom_ > 0 ) then - allocate(pmom_table(nch_table,nrh_table,nbin_table,nmom_table,nPol_table), __NF_STAT__) + allocate(pmom_table(nmom_table,nPol_table,nrh_table,nch_table,nbin_table), __NF_STAT__) end if NF_VERIFY_(nf90_inq_varid(ncid,'lambda',ivarid)) NF_VERIFY_(nf90_get_var(ncid,ivarid,channels_table)) @@ -346,7 +347,7 @@ type(GOCART2G_Mie) function GOCART2G_MieCreate ( MieFile, wavelengths, nmom, rc allocate (this%bsca(this%nrh,this%nch,this%nbin), __NF_STAT__) allocate (this%bbck(this%nrh,this%nch,this%nbin), __NF_STAT__) allocate (this%g(this%nrh,this%nch,this%nbin), __NF_STAT__) - allocate (pback(this%nrh,this%nch,this%nbin,this%nPol), __NF_STAT__) + allocate (pback(this%nPol,this%nrh,this%nch,this%nbin), __NF_STAT__) if ( nmom_ > 0 ) then allocate (this%pmom(this%nrh,this%nch,this%nbin,this%nMom,this%nPol), __NF_STAT__) end if @@ -394,51 +395,65 @@ type(GOCART2G_Mie) function GOCART2G_MieCreate ( MieFile, wavelengths, nmom, rc if ( present(wavelengths) ) then do j = 1, this%nbin do i = 1, this%nrh + bext_tmp = bext_table(i,:,j) + bsca_tmp = bsca_table(i,:,j) + bbck_tmp = bbck_table(i,:,j) + g_tmp = g_table(i,:,j) + refr_tmp = refr_table(i,:,j) + refi_tmp = refi_table(i,:,j) do n = 1, this%nch - call polint(channels_table,bext_table(:,i,j),nch_table, & + call polint(channels_table,bext_tmp,nch_table, & this%wavelengths(n),this%bext(i,n,j),yerr) - call polint(channels_table,bsca_table(:,i,j),nch_table, & + call polint(channels_table,bsca_tmp,nch_table, & this%wavelengths(n),this%bsca(i,n,j),yerr) - call polint(channels_table,bbck_table(:,i,j),nch_table, & + call polint(channels_table,bbck_tmp,nch_table, & this%wavelengths(n),this%bbck(i,n,j),yerr) - call polint(channels_table,g_table(:,i,j),nch_table, & + call polint(channels_table,g_tmp,nch_table, & this%wavelengths(n),this%g(i,n,j),yerr) - call polint(channels_table,refr_table(:,i,j),nch_table, & + call polint(channels_table,refr_tmp,nch_table, & this%wavelengths(n),this%refr(i,n,j),yerr) - call polint(channels_table,refi_table(:,i,j),nch_table, & + call polint(channels_table,refi_tmp,nch_table, & this%wavelengths(n),this%refi(i,n,j),yerr) - do ipol = 1, this%nPol - call polint(channels_table,pback_table(:,i,j,ipol),nch_table, & - this%wavelengths(n),pback(i,n,j,ipol),yerr) - end do - if ( nmom_ > 0 ) then - do imom = 1, this%nMom - do ipol = 1, this%nPol - call polint(channels_table,pmom_table(:,i,j,imom,ipol),nch_table, & + enddo !n + + do ipol = 1, this%nPol + real_tmp = pback_table(ipol,i,:,j) + do n = 1, this%nch + call polint(channels_table,real_tmp,nch_table, & + this%wavelengths(n),pback(ipol,i,n,j),yerr) + end do !n + enddo !ipol + + if ( nmom_ > 0 ) then + do imom = 1, this%nMom + do ipol = 1, this%nPol + real_tmp = pmom_table(imom, ipol,i,:,j) + do n = 1, this%nch + call polint(channels_table, real_tmp,nch_table, & this%wavelengths(n),this%pmom(i,n,j,imom,ipol),yerr) enddo enddo - endif - enddo + enddo + endif enddo enddo else !(no wavelength) !swap the order - this%bext = reshape(bext_table, [nrh_table, nch, nbin_table],order =[2,1,3]) - this%bsca = reshape(bsca_table, [nrh_table, nch, nbin_table],order =[2,1,3]) - this%bbck = reshape(bbck_table, [nrh_table, nch, nbin_table],order =[2,1,3]) - this%g = reshape( g_table, [nrh_table, nch, nbin_table],order =[2,1,3]) - this%refr = reshape(refr_table, [nrh_table, nch, nbin_table],order =[2,1,3]) - this%refi = reshape(refi_table, [nrh_table, nch, nbin_table],order =[2,1,3]) - pback = reshape(pback_table,[nrh_table, nch, nbin_table, npol_table],order =[2,1,3,4]) + this%bext = bext_table + this%bsca = bsca_table + this%bbck = bbck_table + this%g = g_table + this%refr = refr_table + this%refi = refi_table + pback = pback_table if ( nmom_ > 0 ) then - this%pmom = reshape(pmom_table,[nrh_table,nch, nbin_table, nmom_, npol_table], order = [2,1,3,4,5]) + this%pmom = reshape(pmom_table,[nrh_table, nch, nbin_table, nmom_, npol_table], order = [4,5,1,2,3]) endif endif ! Pick p11, p12 - this%p11 = pback(:,:,:,1) - this%p22 = pback(:,:,:,5) + this%p11 = pback(1,:,:,:) + this%p22 = pback(5,:,:,:) ! Now we do a mapping of the RH from the input table to some high ! resolution representation. This is to spare us the need to