33 spccoeff_ismicrowavesensor , &
34 spccoeff_isinfraredsensor , &
35 spccoeff_isvisiblesensor , &
36 spccoeff_isultravioletsensor
40 seasalt_ssam_aerosol , &
41 seasalt_sscm1_aerosol , &
42 seasalt_sscm2_aerosol , &
43 seasalt_sscm3_aerosol , &
44 organic_carbon_aerosol , &
45 black_carbon_aerosol , &
92 '$Id: CRTM_AerosolScatter.f90 60152 2015-08-13 19:19:13Z paul.vandelst@noaa.gov $' 94 INTEGER,
PARAMETER ::
ml = 256
177 SensorIndex , & ! Input
178 ChannelIndex, & ! Input
181 result( error_status )
184 INTEGER ,
INTENT(IN) :: channelindex
185 INTEGER ,
INTENT(IN) :: sensorindex
189 INTEGER :: error_status
191 CHARACTER(*),
PARAMETER :: routine_name =
'CRTM_Compute_AerosolScatter' 193 CHARACTER(ML) :: message
194 INTEGER :: k, ka, l, m, n
195 REAL(fp) :: frequency
196 LOGICAL :: layer_mask(atm%n_layers)
197 INTEGER :: layer_index(atm%n_layers)
198 INTEGER :: naerosol_layers
205 IF ( spccoeff_ismicrowavesensor(
sc(sensorindex)) )
RETURN 206 IF ( atm%n_Aerosols == 0 )
RETURN 209 frequency =
sc(sensorindex)%Wavenumber(channelindex)
213 SELECT CASE(ascat%n_Legendre_Terms)
223 ascat%n_Legendre_Terms = 0
226 WRITE(message,
'("The n_Legendre_Terms in AerosolScatter, ",i0,", do not fit model")') &
227 ascat%n_Legendre_Terms
237 aerosol_loop:
DO n = 1, atm%n_Aerosols
242 naerosol_layers = count(layer_mask)
243 IF ( naerosol_layers == 0 ) cycle aerosol_loop
249 layer_index(1:naerosol_layers) = pack((/(k,k=1,atm%Aerosol(n)%n_Layers)/), layer_mask)
250 aerosol_layer_loop:
DO k = 1, naerosol_layers
256 atm%Aerosol(n)%Type , &
257 atm%Aerosol(n)%Effective_Radius(ka), &
260 asv%pcoeff(:,:,ka,n) , &
264 IF( asv%ke(ka,n) <=
zero )
THEN 268 IF( asv%w(ka,n) <=
zero )
THEN 270 asv%pcoeff(:,:,ka,n) =
zero 272 IF( asv%w(ka,n) >=
one )
THEN 290 ascat%Optical_Depth(ka) = ascat%Optical_Depth(ka) + &
291 (asv%ke(ka,n)*atm%Aerosol(n)%Concentration(ka))
297 IF( ascat%n_Phase_Elements > 0 .and. ascat%Include_Scattering )
THEN 308 bs = atm%Aerosol(n)%Concentration(ka) * asv%ke(ka,n) * asv%w(ka,n)
309 asv%Total_bs(ka) = asv%Total_bs(ka) + bs
310 ascat%Single_Scatter_Albedo(ka) = ascat%Single_Scatter_Albedo(ka) + bs
312 DO m = 1, ascat%n_Phase_Elements
313 DO l = 0, ascat%n_Legendre_Terms
314 ascat%Phase_Coefficient(l,m,ka) = ascat%Phase_Coefficient(l,m,ka) + &
315 (asv%pcoeff(l,m,ka,n) * bs)
319 END DO aerosol_layer_loop
415 AScat , & ! FWD Input
416 Atm_TL , & ! TL Input
417 SensorIndex , & ! Input
418 ChannelIndex, & ! Input
419 AScat_TL , & ! TL Input
421 result( error_status )
426 INTEGER ,
INTENT(IN) :: sensorindex
427 INTEGER ,
INTENT(IN) :: channelindex
431 INTEGER :: error_status
433 CHARACTER(*),
PARAMETER :: routine_name =
'CRTM_Compute_AerosolScatter_TL' 435 INTEGER :: k, ka, l, m, n
436 INTEGER :: n_legendre_terms, n_phase_elements
437 REAL(fp) :: frequency
438 LOGICAL :: layer_mask(atm%n_layers)
439 INTEGER :: layer_index(atm%n_layers)
440 INTEGER :: naerosol_layers
441 REAL(fp) :: ke_tl, w_tl
442 REAL(fp) :: pcoeff_tl(0:ascat%n_legendre_terms, ascat%n_phase_elements)
443 REAL(fp) :: bs, bs_tl
449 IF ( spccoeff_ismicrowavesensor(
sc(sensorindex)) )
RETURN 450 IF ( atm%n_Aerosols == 0 )
RETURN 452 frequency =
sc(sensorindex)%Wavenumber(channelindex)
454 n_legendre_terms = ascat_tl%n_Legendre_Terms
455 n_phase_elements = ascat_tl%n_Phase_Elements
456 ascat_tl%lOffset = ascat%lOffset
462 aerosol_loop:
DO n = 1, atm%n_Aerosols
467 naerosol_layers = count(layer_mask)
468 IF (naerosol_layers == 0) cycle aerosol_loop
474 layer_index(1:naerosol_layers) = pack((/(k,k=1,atm%Aerosol(n)%n_Layers)/), layer_mask)
475 aerosol_layer_loop:
DO k = 1, naerosol_layers
480 atm%Aerosol(n)%Type , &
483 atm_tl%Aerosol(n)%Effective_Radius(ka), &
490 IF( asv%ke(ka,n) <=
zero )
THEN 494 IF( asv%w(ka,n) <=
zero )
THEN 498 IF( asv%w(ka,n) >=
one )
THEN 503 ascat_tl%Optical_Depth(ka) = ascat_tl%Optical_Depth(ka) + &
504 (ke_tl * atm%Aerosol(n)%Concentration(ka)) + &
505 (asv%ke(ka,n) * atm_tl%Aerosol(n)%Concentration(ka))
508 IF( n_phase_elements > 0 .and. ascat%Include_Scattering )
THEN 510 bs = atm%Aerosol(n)%Concentration(ka) * asv%ke(ka,n) * asv%w(ka,n)
511 bs_tl = (atm_tl%Aerosol(n)%Concentration(ka) * asv%ke(ka,n) * asv%w(ka,n) ) + &
512 (atm%Aerosol(n)%Concentration(ka) * ke_tl * asv%w(ka,n) ) + &
513 (atm%Aerosol(n)%Concentration(ka) * asv%ke(ka,n) * w_tl )
514 ascat_tl%Single_Scatter_Albedo(ka) = ascat_tl%Single_Scatter_Albedo(ka) + bs_tl
516 DO m = 1, n_phase_elements
517 DO l = 0, n_legendre_terms
518 ascat_tl%Phase_Coefficient(l,m,ka) = ascat_tl%Phase_Coefficient(l,m,ka) + &
519 (pcoeff_tl(l,m) * bs ) + &
520 (asv%pcoeff(l,m,ka,n) * bs_tl)
524 END DO aerosol_layer_loop
621 AScat , & ! FWD Input
622 AScat_AD , & ! AD Input
623 SensorIndex , & ! Input
624 ChannelIndex, & ! Input
625 Atm_AD , & ! AD Output
627 result( error_status )
632 INTEGER ,
INTENT(IN) :: sensorindex
633 INTEGER ,
INTENT(IN) :: channelindex
637 INTEGER :: error_status
639 CHARACTER(*),
PARAMETER :: routine_name =
'CRTM_Compute_AerosolScatter_AD' 641 INTEGER :: k, ka, l, m, n
642 INTEGER :: n_legendre_terms, n_phase_elements
643 REAL(fp) :: frequency
644 LOGICAL :: layer_mask(atm%n_layers)
645 INTEGER :: layer_index(atm%n_layers)
646 INTEGER :: naerosol_layers
647 REAL(fp) :: ke_ad, w_ad
648 REAL(fp) :: pcoeff_ad(0:ascat%n_legendre_terms, ascat%n_phase_elements)
649 REAL(fp) :: bs, bs_ad
655 IF ( spccoeff_ismicrowavesensor(
sc(sensorindex)) )
RETURN 656 IF ( atm%n_Aerosols == 0 )
RETURN 658 frequency =
sc(sensorindex)%Wavenumber(channelindex)
660 n_legendre_terms = ascat_ad%n_Legendre_Terms
661 n_phase_elements = ascat_ad%n_Phase_Elements
662 ascat_ad%lOffset = ascat%lOffset
674 aerosol_loop:
DO n = 1, atm%n_Aerosols
679 naerosol_layers = count(layer_mask)
680 IF ( naerosol_layers == 0 ) cycle aerosol_loop
685 layer_index(1:naerosol_layers) = pack((/(k,k=1,atm%Aerosol(n)%n_Layers)/), layer_mask)
686 aerosol_layer_loop:
DO k = 1, naerosol_layers
698 IF( n_phase_elements > 0 .and. ascat%Include_Scattering )
THEN 701 bs = atm%Aerosol(n)%Concentration(ka) * asv%ke(ka,n) * asv%w(ka,n)
702 DO m = 1, n_phase_elements
703 DO l = 0, n_legendre_terms
704 bs_ad = bs_ad + (asv%pcoeff(l,m,ka,n) * ascat_ad%Phase_Coefficient(l,m,ka))
705 pcoeff_ad(l,m) = pcoeff_ad(l,m) + (bs * ascat_ad%Phase_Coefficient(l,m,ka))
711 bs_ad = bs_ad + ascat_ad%Single_Scatter_Albedo(ka)
712 w_ad = w_ad + (atm%Aerosol(n)%Concentration(ka) * asv%ke(ka,n)* bs_ad )
717 atm_ad%Aerosol(n)%Concentration(ka) = atm_ad%Aerosol(n)%Concentration(ka) + &
718 (asv%ke(ka,n) * ascat_ad%Optical_Depth(ka))
719 ke_ad = ke_ad + (atm%Aerosol(n)%Concentration(ka) * ascat_ad%Optical_Depth(ka))
724 ke_ad = ke_ad + (atm%Aerosol(n)%Concentration(ka) * bs_ad * asv%w(ka,n) )
725 atm_ad%Aerosol(n)%Concentration(ka) = atm_ad%Aerosol(n)%Concentration(ka) + &
726 ( bs_ad * asv%ke(ka,n) * asv%w(ka,n) )
729 IF( asv%w(ka,n) >=
one )
THEN 732 IF( asv%ke(ka,n) <=
zero )
THEN 736 IF( asv%w(ka,n) <=
zero )
THEN 741 IF( asv%w(ka,n) >=
one )
THEN 744 IF( asv%ke(ka,n) <=
zero )
THEN 748 IF( asv%w(ka,n) <=
zero )
THEN 755 atm%Aerosol(n)%Type , &
761 atm_ad%Aerosol(n)%Effective_Radius(ka), &
764 END DO aerosol_layer_loop
784 INTEGER,
INTENT(IN) :: aerosol_type
786 SELECT CASE (aerosol_type)
787 CASE(dust_aerosol) ; k=1
788 CASE(seasalt_ssam_aerosol) ; k=2
789 CASE(seasalt_sscm1_aerosol) ; k=3
790 CASE(seasalt_sscm2_aerosol) ; k=4
791 CASE(seasalt_sscm3_aerosol) ; k=5
792 CASE(organic_carbon_aerosol) ; k=6
793 CASE(black_carbon_aerosol) ; k=7
794 CASE(sulfate_aerosol) ; k=8
807 SUBROUTINE get_aerosol_opt( AerosolScatter, & ! Input AerosolScatter structure
808 Frequency , & ! Input in cm^-1
809 Aerosol_Type , & ! Input see CRTM_Aerosol_Define.f90
810 Reff , & ! Input effective radius (mm)
816 TYPE(CRTM_AtmOptics_type),
INTENT(IN) :: AerosolScatter
817 REAL(fp) ,
INTENT(IN) :: Frequency
818 INTEGER ,
INTENT(IN) :: Aerosol_Type
819 REAL(fp) ,
INTENT(IN) :: Reff
820 REAL(fp) ,
INTENT(OUT) :: ke
821 REAL(fp) ,
INTENT(OUT) :: w
822 REAL(fp) ,
INTENT(IN OUT) :: pcoeff(0:,:)
823 TYPE(ASinterp_type) ,
INTENT(IN OUT) :: asi
837 CALL find_index(
aeroc%Frequency(:),asi%f_int,asi%i1,asi%i2, asi%f_outbound)
838 asi%f =
aeroc%Frequency(asi%i1:asi%i2)
841 CALL find_index(
aeroc%Reff(:,k), asi%r_int, asi%j1,asi%j2, asi%r_outbound)
842 asi%r =
aeroc%Reff(asi%j1:asi%j2,k)
848 CALL lpoly( asi%f, asi%f_int, &
851 CALL lpoly( asi%r, asi%r_int, &
857 CALL interp_2d(
aeroc%ke(asi%i1:asi%i2,asi%j1:asi%j2,k), asi%wlp, asi%xlp, ke )
858 CALL interp_2d(
aeroc%w(asi%i1:asi%i2,asi%j1:asi%j2,k) , asi%wlp, asi%xlp, w )
859 IF (aerosolscatter%n_Phase_Elements > 0 .and. aerosolscatter%Include_Scattering )
THEN 861 DO m = 1, aerosolscatter%n_Phase_Elements
862 DO l = 1, aerosolscatter%n_Legendre_Terms
863 CALL interp_2d(
aeroc%pcoeff(asi%i1:asi%i2,asi%j1:asi%j2,k,l+aerosolscatter%lOffset,m), &
864 asi%wlp, asi%xlp, pcoeff(l,m) )
884 Aerosol_Type , & ! Input see CRTM_Aerosol_Define.f90
887 Reff_TL , & ! Input TL effective radius (mm)
894 TYPE(CRTM_AtmOptics_type),
INTENT(IN) :: AerosolScatter_TL
895 INTEGER ,
INTENT(IN) :: Aerosol_Type
896 REAL(fp),
INTENT(IN) :: w, ke, Reff_TL
897 REAL(fp),
INTENT(OUT) :: ke_TL
898 REAL(fp),
INTENT(OUT) :: w_TL
899 REAL(fp),
INTENT(IN OUT) :: pcoeff_TL(0:,:)
900 TYPE(ASinterp_type),
INTENT(IN) :: asi
903 REAL(fp) :: f_int_TL, r_int_TL
904 REAL(fp) :: f_TL(NPTS), r_TL(NPTS)
905 REAL(fp) :: z_TL(NPTS,NPTS)
906 TYPE(LPoly_type) :: wlp_TL, xlp_TL
907 REAL(fp),
POINTER :: z(:,:) => null()
913 IF ( asi%f_outbound .AND. asi%r_outbound )
THEN 949 z =>
aeroc%ke(asi%i1:asi%i2,asi%j1:asi%j2,k)
951 z_tl, wlp_tl , xlp_tl , &
954 z =>
aeroc%w(asi%i1:asi%i2,asi%j1:asi%j2,k)
956 z_tl, wlp_tl , xlp_tl , &
959 IF (aerosolscatter_tl%n_Phase_Elements > 0 .and. aerosolscatter_tl%Include_Scattering )
THEN 960 pcoeff_tl(0,1) =
zero 961 DO m = 1, aerosolscatter_tl%n_Phase_Elements
962 DO l = 1, aerosolscatter_tl%n_Legendre_Terms
963 z =>
aeroc%pcoeff(asi%i1:asi%i2,asi%j1:asi%j2,k,l+aerosolscatter_tl%lOffset,m)
965 z_tl, wlp_tl , xlp_tl , &
972 ke_tl = ke_tl * (
one - w) - ke/(
one -w) * w_tl
990 SUBROUTINE get_aerosol_opt_ad( AerosolScatter_AD, & ! Input AerosolScatter AD structure
991 Aerosol_Type , & ! Input see CRTM_Aerosol_Define.f90
994 ke_AD , & ! AD Input extinction cross section
995 w_AD , & ! AD Input single scatter albedo
996 pcoeff_AD , & ! AD Input spherical Legendre coefficients
997 Reff_AD , & ! AD Output effective radius
1000 TYPE(CRTM_AtmOptics_type),
INTENT(IN) :: AerosolScatter_AD
1001 INTEGER ,
INTENT(IN) :: Aerosol_Type
1002 REAL(fp),
INTENT(IN) :: ke, w
1003 REAL(fp),
INTENT(IN OUT) :: ke_AD
1004 REAL(fp),
INTENT(IN OUT) :: w_AD
1005 REAL(fp),
INTENT(IN OUT) :: pcoeff_AD(0:,:)
1006 REAL(fp),
INTENT(IN OUT) :: Reff_AD
1007 TYPE(ASinterp_type),
INTENT(IN) :: asi
1010 REAL(fp) :: f_int_AD, r_int_AD
1011 REAL(fp) :: f_AD(NPTS), r_AD(NPTS)
1012 REAL(fp) :: z_AD(NPTS,NPTS)
1013 TYPE(LPoly_type) :: wlp_AD, xlp_AD
1014 REAL(fp),
POINTER :: z(:,:) => null()
1021 IF ( asi%f_outbound .AND. asi%r_outbound )
THEN 1046 IF (aerosolscatter_ad%n_Phase_Elements > 0 .and. aerosolscatter_ad%Include_Scattering )
THEN 1047 DO m = 1, aerosolscatter_ad%n_Phase_Elements
1048 DO l = 1, aerosolscatter_ad%n_Legendre_Terms
1049 z =>
aeroc%pcoeff(asi%i1:asi%i2,asi%j1:asi%j2,k,l+aerosolscatter_ad%lOffset,m)
1052 z_ad, wlp_ad, xlp_ad )
1055 pcoeff_ad(0,1) =
zero 1059 w_ad = w_ad - ke/(
one -w) * ke_ad
1060 ke_ad = ke_ad * (
one - w)
1068 z =>
aeroc%w(asi%i1:asi%i2,asi%j1:asi%j2,k)
1071 z_ad, wlp_ad , xlp_ad )
1073 z =>
aeroc%ke(asi%i1:asi%i2,asi%j1:asi%j2,k)
1076 z_ad, wlp_ad , xlp_ad )
1094 reff_ad = reff_ad + r_int_ad
integer function, public crtm_compute_aerosolscatter_ad(Atm, AScat, AScat_AD, SensorIndex, ChannelIndex, Atm_AD, ASV)
subroutine get_aerosol_opt_tl(AerosolScatter_TL, Aerosol_Type, ke, w, Reff_TL, ke_TL, w_TL, pcoeff_TL, asi)
subroutine, public interp_3d_ad(z, ulp, vlp, wlp, z_int_AD, z_AD, ulp_AD, vlp_AD, wlp_AD)
subroutine, public interp_3d_tl(z, ulp, vlp, wlp, z_TL, ulp_TL, vlp_TL, wlp_TL, z_int_TL)
integer, parameter, public failure
real(fp), parameter, public onepointfive
real(fp), parameter, public zero
integer, parameter, public max_n_phase_elements
integer function, public crtm_compute_aerosolscatter_tl(Atm, AScat, Atm_TL, SensorIndex, ChannelIndex, AScat_TL, ASV)
integer, parameter, public fp
character(*), parameter module_version_id
integer, parameter thirtytwo_streams
integer, parameter sixteen_streams
integer, parameter, public max_n_legendre_terms
logical, parameter, public hgphase
integer, parameter two_streams
subroutine, public clear_lpoly(p)
subroutine, public lpoly_ad(x, x_int, p, p_AD, x_AD, x_int_AD)
real(fp), parameter, public bs_threshold
subroutine get_aerosol_opt_ad(AerosolScatter_AD, Aerosol_Type, ke, w, ke_AD, w_AD, pcoeff_AD, Reff_AD, asi)
integer function, public crtm_compute_aerosolscatter(Atm, SensorIndex, ChannelIndex, AScat, ASV)
integer, parameter, public max_n_aerosols
type(aerosolcoeff_type), target, save, public aeroc
real(fp), parameter, public aerosol_content_threshold
real(fp), parameter, public one
integer function aerosol_type_index(Aerosol_Type)
recursive subroutine, public display_message(Routine_Name, Message, Error_State, Message_Log)
elemental subroutine, public asvar_destroy(self)
subroutine get_aerosol_opt(AerosolScatter, Frequency, Aerosol_Type, Reff, ke, w, pcoeff, asi)
subroutine, public interp_2d_ad(z, ulp, vlp, z_int_AD, z_AD, ulp_AD, vlp_AD)
subroutine, public lpoly(x, x_int, p)
integer, parameter, public npts
type(spccoeff_type), dimension(:), allocatable, save, public sc
elemental logical function, public asvar_associated(self)
integer, parameter, public max_n_layers
real(fp), parameter, public point_5
subroutine, public interp_3d(z, ulp, vlp, wlp, z_int)
integer, parameter four_streams
elemental subroutine, public asvar_create(self, n_Legendre_Terms, n_Phase_Elements, n_Layers, n_Aerosols)
integer, parameter six_streams
integer, parameter eight_streams
subroutine, public lpoly_tl(x, x_int, p, x_TL, x_int_TL, p_TL)
subroutine, public interp_1d(z, ulp, z_int)
integer, parameter, public success
subroutine, public interp_2d_tl(z, ulp, vlp, z_TL, ulp_TL, vlp_TL, z_int_TL)
subroutine, public interp_2d(z, ulp, vlp, z_int)